Archive/jak-project
1
0
Fork 0
mirror of https://github.com/open-goal/jak-project.git synced 2024-10-20 21:27:52 -04:00
Code Issues Actions 3 Packages Projects Releases Wiki Activity
jak-project/goal_src/jak1/kernel/gkernel.gc
ManDude 1f4044b9ff
Jak 2 controller LED implementation (#3035) 
Adds controller LED features to Jak 2:
- progressive flickering denoting health
- copies tomb simon says puzzle colors
- unique colors for each gun
- orange color for being indax
- yellow color for being in mech
- purple color for being darkjak
- blue color for being in board
- red flash when wanted.

May add more features later?

Also did some minor clean-up on some types.
2023-09-28 02:47:09 +01:00

2617 lines
89 KiB
Common Lisp
Raw Blame History

;;-*-Lisp-*-
(in-package goal)
;; name: gkernel.gc
;; name in dgo: gkernel
;; dgos: KERNEL
;; The GOAL kernel provides:
;; - threads/stack management
;; - processes, and the process pools
;; - actor heap compacting GC
;; - process suspend
;; - executing the listener function and printing the result in the REPL
;; - catch/throw and stack frame utilities for the state system
;; - package loading (mostly unused loading system separate from levels)
;; Fwd
(define-extern change-parent (function process-tree process-tree process-tree))
;; DECOMP BEGINS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; System Globals
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Set to #f to not use the fancy printing of results
(define *use-old-listener-print* #f)
;; Set version number symbols
(define *kernel-version* (the binteger (logior (ash *kernel-major-version* 16) *kernel-minor-version*)))
(define *irx-version* (the binteger (logior (ash *irx-major-version* 16) *irx-minor-version*)))
;; Set default options. The C Kernel may modify these before loading the engine.
;; Can be 'boot, 'listener, or 'debug-boot
;; set to 'boot when DiskBooting.
(define *kernel-boot-mode* 'listener) ;; mostly unused.
;; DebugBootLevel in C Kernel
(define *kernel-boot-level* (the symbol #f)) ;; doesn't do anything.
;; The number of DECI messages received.
;; The C Kernel increments this.
(define *deci-count* 0)
;; Some debug stats. Unused.
(define *last-loado-length* 0)
(define *last-loado-global-usage* 0)
(define *last-loado-debug-usage* 0)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Relocate
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Objects on a dynamic process heap may be relocated.
;; They should provide their own relocate method to do any fixups
;; for any references.
;; Note - the actual relocation method of process is in relocate.gc.
(defmethod relocate object ((this object) (offset int))
this
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Kernel Package System
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The kernel has a weird package system. It's not really used and doesn't do much.
;; Both the C Kernel and GOAL Kernel update the kernel-packages list.
;; The list is used to avoid loading the same package multiple times.
(define *kernel-packages* '())
(defun load-package ((package string) (allocation kheap))
"Load a Package from a CGO/DGO"
(unless (nmember package *kernel-packages*)
(dgo-load package allocation (link-flag output-load-msg output-load-true-msg execute-login print-login) #x200000)
(set! *kernel-packages* (cons package *kernel-packages*))
)
)
(defun unload-package ((package string))
"Mark a package as unloaded, if it was loaded previously"
(let ((pack (nmember package *kernel-packages*)))
(when pack
(set! *kernel-packages* (delete! (car pack) *kernel-packages*))
)
*kernel-packages*
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Kernel Globals
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The kernel context is a global which stores the state of the kernel.
(define *kernel-context* (new 'static 'kernel-context
:prevent-from-run (process-mask execute sleep)
:next-pid 2 ;; 1 will be listener
:current-process #f
:relocating-process #f
:low-memory-message #t
)
)
;; the main stack for running GOAL code!
;; most user code runs using *dram-stack*
(define *dram-stack* (new 'global 'array 'uint8 DPROCESS_STACK_SIZE))
;; note - this name is a bit confusing. The kernel-dram-stack is not the stack that the kernel runs in.
;; I think it refers to the fact that it's _not_ the scratchpad stack
(defconstant *kernel-dram-stack* (&+ *dram-stack* DPROCESS_STACK_SIZE))
;; another stack for running GOAL processes, this one uses the scratchpad (fast memory).
(set! (-> *kernel-context* fast-stack-top) *scratch-memory-top*)
;; A context with all process masks set to 0. This can be used to iterate through a process tree
;; without executing anything, to find a process for instance.
(define *null-kernel-context* (new 'static 'kernel-context))
;; scratchpad setup
(#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*)
(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))
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Thread and CPU Thread
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; A GOAL thread represents the execution of code in a process.
;; Each process has a "main thread", which is suspended and resumed.
;; A process may also execute various temporary threads which always run until completion.
;; A "temporary thread" cannot suspend and resume, but a "main thread" can.
;; The currently executing thread of a process is the "top-thread".
;; Threads that suspend do so by saving their saved registers and their stack.
;; All threads run on a single large stack and have small "backup" stacks that are much smaller than the main stack.
;; as a result, suspending can fail if you are using more stack than the size of your backup stack.
;; This "backup stack" can be different sizes for different threads and makes the thread type dynamic.
;; The main thread is stored on the process heap, as they need the same lifetime as the process.
;; The temporary threads are stored on the stack. There can be only one temporary thread at a time.
;; All threads are actually cpu-threads. It's not clear why there are two separate types.
;; Perhaps the thread was the public interface and cpu-thread is internal to the kernel?
(defmethod delete thread ((this thread))
"Clean up a temporary thread after it is done being used.
This assumes it's the top-thread of the process and restores the previous top thread."
(when (eq? this (-> this process main-thread))
;; We have attempted to delete the main thread, which is bad.
(break)
)
;; restore the old top-thread.
(set! (-> this process top-thread) (-> this previous))
(none)
)
(defmethod print thread ((this thread))
"Print 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! thread ((this thread) (stack-size int))
"Set the backup stack size of a thread. This should only be done on the main-thread.
This should be done immediately after allocating the main-thread.
Users can do this if they want a larger or smaller backup stack than the default."
(let ((proc (-> this process)))
(cond
((neq? this (-> proc main-thread))
;; oops. can only change the size of a main-thread's stack.
(msg-err "illegal attempt change stack size of ~A when the main-thread is not the top-thread.~%" proc)
(break) ;; ADDED
)
((= (-> this stack-size) stack-size)
;; we already have this size. Don't do anything.
)
((eq? (-> proc heap-cur) (&+ this (-> this type size) (- *gtype-basic-offset*) (-> this stack-size)))
;; our heap cur point to right after us. So we can safely bump it forward to give us more space.
(set! (-> proc heap-cur) (the pointer (&+ this (-> this type size) (- *gtype-basic-offset*) stack-size)))
(set! (-> this stack-size) stack-size)
)
(else
(msg-err "illegal attempt change stack size of ~A after more heap allocation has occured.~%" proc)
(break)
)
)
)
(none)
)
(defmethod new cpu-thread ((allocation symbol) (type-to-make type) (parent-process process) (name symbol) (stack-size int) (stack-top pointer))
"Create a new CPU thread. 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)"
;; first, let's see if we're doing the main or temp thread
(let* ((this (cond
((-> parent-process top-thread)
;; we're allocating a temporary thread, the main thread already exists.
;; we can stash the cpu-thread structure at the bottom of the stack.
;; we use the smaller PROCESS_STACK_SIZE, in case we're running on the scratchpad.
(the cpu-thread (&+ stack-top (- PROCESS_STACK_SIZE) *gtype-basic-offset*))
)
(else
;; the main thread. We need the main thread's cpu-thread to stick around, so we put it in the
;; process heap.
(let ((alloc (align16 (-> parent-process heap-cur)))) ;; start at heap cur, aligned
;; bump heap to include our thread + its stack
(set! (-> parent-process heap-cur) (the pointer (+ alloc (-> type-to-make size) stack-size)))
(the cpu-thread (+ alloc *gtype-basic-offset*))
)
)
)))
;; set up the type manually, as we allocated the memory manually
(set! (-> this type) type-to-make)
;; set up thread
(set! (-> this name) name)
(set! (-> this process) parent-process)
;; start stack at the top
(set! (-> this sp) stack-top)
(set! (-> this stack-top) stack-top)
;; remember the previous thread, in case we're a temp thread
(set! (-> this previous) (-> parent-process top-thread))
;; and make us the top!
(set! (-> parent-process top-thread) this)
;; set up our suspend/resume hooks. By default just use the thread's methods.
;; but something else could install a different hook if needed.
(set! (-> this suspend-hook) (method-of-object this thread-suspend))
(set! (-> this resume-hook) (method-of-object this thread-resume))
;; remember how much space we have for the backup stack.
(set! (-> this stack-size) stack-size)
this
)
)
(defmethod asize-of cpu-thread ((this cpu-thread))
"Get the size of a cpu-thread"
;; we need this because the cpu-thread is stored in the process stack
(the int (+ (-> this type size) (-> this stack-size)))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Remove Exit
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defbehavior remove-exit process ()
"Pops a single stack frame, if there is one.
User code can call this before doing a 'go' to avoid running the exit for the current state."
(when (-> self stack-frame-top)
(set! (-> self stack-frame-top) (-> self stack-frame-top next))
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Tree
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GOAL processes are stored in a left child, right sibling tree.
;; The base class of process is process-tree.
;; Each process-tree element has a process-mask which indicates what type of node it is.
(defun-debug stream<-process-mask ((arg0 object) (arg1 process-mask))
(bit-enum->string process-mask arg1 arg0)
arg1
)
(define *master-mode* 'game) ;; game, process, menu, pause
(define *pause-lock* #f) ;; set to #t when paused and doing a single frame advance with R2.
(defmethod new process-tree ((allocation symbol) (type-to-make type) (name basic))
"Create a process-tree node"
;; allocate
(let ((this (object-new allocation type-to-make)))
(set! (-> this name) name)
(set! (-> this mask) (process-mask process-tree))
(set! (-> this parent) #f)
(set! (-> this brother) #f)
(set! (-> this child) #f)
(set! (-> this self) this)
(set! (-> this ppointer) (the (pointer process) (&-> this self)))
this
)
)
(defmethod inspect process-tree ((this process-tree))
"Inspect a process-tree node."
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~Tname: ~S~%" (-> this name))
(format #t "~Tmask: #x~X~%" (-> this mask))
(format #t "~Tparent: ~A~%" (ppointer->process (-> this parent)))
(format #t "~Tbrother: ~A~%" (ppointer->process (-> this brother)))
(format #t "~Tchild: ~A~%" (ppointer->process (-> this child)))
this
)
(defmethod new process ((allocation symbol) (type-to-make type) (name basic) (stack-size int))
"Allocate a new process.
The process stack is initially set to the entire process memory."
(let ((this (if (eq? (-> allocation type) symbol)
(object-new allocation type-to-make (the int (+ (-> process size) stack-size))) ;; symbol, allocate on heap
(the process (&+ allocation *gtype-basic-offset*))))) ;; treat as address.
;; initialize
(set! (-> this name) name)
(set! (-> this status) 'dead)
(set! (-> this pid) 0)
(set! (-> this pool) #f)
(set! (-> this allocated-length) stack-size)
(set! (-> this top-thread) #f)
(set! (-> this main-thread) #f)
;; set up the heap to start at the stack
(set! (-> this heap-cur) (-> this stack))
(set! (-> this heap-base) (-> this stack))
;; and end at the end of the stack.
(set! (-> this heap-top) (&-> (-> this stack) (-> this allocated-length)))
;;;;;;;;;;;;;;;;;;;;;;;;;
;; heap top-base bug
;;;;;;;;;;;;;;;;;;;;;;;;;
;; original there was something like (set! (-> heap-top-base) (-> heap-top))
;; but this overlaps with the stack-frame-top and did nothing.
;; this is likely because they added the concept of heap "top" to kheaps in
;; general, but not to process heaps.
;; setup state stuff
(set! (-> this stack-frame-top) #f)
(set! (-> this state) #f)
(set! (-> this next-state) #f)
(set! (-> this entity) #f)
;; setup handlers
(set! (-> this trans-hook) #f)
(set! (-> this post-hook) #f)
(set! (-> this event-hook) #f)
;; setup process tree
(set! (-> this parent) #f)
(set! (-> this brother) #f)
(set! (-> this child) #f)
;; setup reference stuff.
(set! (-> this self) this)
(set! (-> this ppointer) (the (pointer process) (&-> this self)))
this
)
)
(defun inspect-process-heap ((this process))
"Inspect the heap of a process."
(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)))))
)
)
)
(defmethod inspect process ((this process))
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~Tname: ~S~%" (-> this name))
(format #t "~Tmask: #x~X~%" (-> this mask))
(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 "~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))
;; print all objects on the process heap
(protect (*print-column*)
(+! *print-column* *tab-size*)
(format #t "----~%")
(inspect-process-heap this)
(format #t "----~%")
)
(format #t "~Tallocated-length: ~D~%" (-> this allocated-length))
(format #t "~Tstack[~D] @ #x~X~%" (-> this allocated-length) (-> this stack))
this
)
(defmethod asize-of process ((this process))
(the int (+ (-> process size) (-> this allocated-length)))
)
(defmethod print process ((this process))
(format #t "#<~A ~S ~A :state ~S "
(-> this type)
(-> this name)
(-> this status)
(when (-> this state) (-> this state name)))
(format #t ":stack ~D/~D :heap ~D/~D @ #x~X>"
(process-stack-used this)
(process-stack-size this)
(process-heap-used this)
(process-heap-size this)
this
)
this
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Context Suspend And Resume - Kernel
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the following functions are used for going from the kernel to threads and back.
;; saved registers: rbx, rbp, r10, r11, r12
;; DANGER - THE KERNEL DOES NOT SAVE ITS FLOATING POINT CONTEXT!!!!
;; we use this to store a GOAL pointer to the kernel's stack pointer when executing user code.
;; to get back to the kernel, we use this global symbol.
(define-extern *kernel-sp* pointer)
(defun return-from-thread ()
"Context switch to the saved kernel context now.
This is intended to be jumped to with the ret instruction (return trampoline)
at the end of a normal function, so this should preserve rax.
To make sure this happens, all ops should be asm ops and we should have no
GOAL expressions."
(declare (asm-func none)
;(print-asm)
)
(rlet ((sp :reg rsp :type uint)
(off :reg r15 :type uint)
(s0 :reg rbx :type uint)
(s1 :reg rbp :type uint)
(s2 :reg r10 :type uint)
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint)
)
;; get the kernel stack pointer as a GOAL pointer (won't use a temp reg)
(.load-sym :sext #f sp *kernel-sp*)
;; convert it back to a real pointer
(.add sp off)
;; restore saved registers...
;; without coloring system because this is "cheating" and modifying saved registers without backing up.
(.pop :color #f s4)
(.pop :color #f s3)
(.pop :color #f s2)
(.pop :color #f s1)
(.pop :color #f s0)
;; return to the kernel function that called the user code
;; rax should still contain the return value.
(.ret)
)
)
(defun return-from-thread-dead ()
"Like return from thread, but we clean up our process with deactivate first.
The return register is not preserved here, instead we return the value of deactivate"
(declare (asm-func none)
;(print-asm)
)
(rlet ((pp :reg r13 :type process)
(sp :reg rsp :type uint)
(off :reg r15 :type uint)
(s0 :reg rbx :type uint)
(s1 :reg rbp :type uint)
(s2 :reg r10 :type uint)
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint)
)
;; first call the deactivate method.
(deactivate pp)
;; get the kernel stack pointer as a GOAL pointer
(.load-sym :sext #f sp *kernel-sp*)
;; convert it back to a real pointer
(.add sp off)
;; restore saved registers...
;; without coloring system because this is "cheating".
(.pop :color #f s4)
(.pop :color #f s3)
(.pop :color #f s2)
(.pop :color #f s1)
(.pop :color #f s0)
;; return to the kernel function that called the user code
(.ret)
)
)
(defmacro abandon-thread ()
;; abandon this one too.
;; NOTE - this is different from GOAL.
;; GOAL installs this as the return address for this function and returns normally.
;; but we don't because I don't have an easy way to find where to stick this.
;; I can't see how this makes a difference, as all non-main threads seem
;; temporary, but if this turns out to be false, we will need to change this.
`(rlet ((temp)
(off :reg r15 :type uint :reset-here #t))
(.mov temp return-from-thread) ;; could probably just call this...
(.add temp off)
(.push temp)
(.ret)
)
)
(defun reset-and-call ((this thread) (func function))
"Make the given thread the top thread, reset the stack, and call the function.
Sets up a return trampoline so when the function returns it will return to the
kernel context. Will NOT deactivate on return, so this is intended for temporary threads.
NOTE: this should only be done from the kernel, running on the
kernel's stack."
(declare (asm-func object)
)
(rlet ((pp :reg r13 :type process)
(sp :reg rsp :type uint)
(off :reg r15 :type uint)
(s0 :reg rbx :type uint)
(s1 :reg rbp :type uint)
(s2 :reg r10 :type uint)
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint)
(temp :reg rax :type uint)
)
;; set up the process pointer
(set! pp (-> this process))
;; mark the process as running and set its top thread
(set! (-> pp status) 'running)
(set! (-> pp top-thread) 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)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Context Suspend And Resume - Thread
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; these are for resuming and suspending main threads.
(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 ((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 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 ((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)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Dead Pool
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; a dead pool is just a collection of dead processes of a fixed size.
(define-extern *debug-dead-pool* dead-pool-heap)
(defmethod new dead-pool ((allocation symbol) (type-to-make type) (count int) (stack-size int) (name basic))
"Create a pool of count dead processes, each with a fixed size stack-size"
(let ((this (object-new allocation type-to-make)))
;; setup process naming
(set! (-> this name) name)
(set! (-> this mask) (process-mask process-tree))
;; setup process tree
(set! (-> this parent) #f)
(set! (-> this brother) #f)
(set! (-> this child) #f)
;; setup ref
(set! (-> this self) this)
(set! (-> this ppointer) (the (pointer process) (&-> this self)))
(dotimes (i count)
;; create each process
(let ((old-bro (-> this child))
(next ((method-of-type process new) allocation process 'dead stack-size)))
(set! (-> this child) (process->ppointer next))
(set! (-> next parent) (process->ppointer this))
(set! (-> next pool) this)
(set! (-> next brother) old-bro)
)
)
this
)
)
(defmethod get-process dead-pool ((this dead-pool) (type-to-make type) (stack-size int))
"Get a process from this dead pool of the given type."
(let ((proc (-> this child)))
(when (and (not proc) *debug-segment* (neq? this *debug-dead-pool*))
;; we failed, but we're in debug mode and not looking at the debug pool
;; try again from the debug pool and warn if this works
(set! proc (the (pointer process-tree) (get-process *debug-dead-pool* type-to-make stack-size)))
(when proc
(format 0 "WARNING: ~A ~A had to be allocated from the debug pool, because ~A was empty.~%"
type-to-make (ppointer->process proc) (-> this name))
)
;; there's a bug here. proc is a process here, but will be used as a process pointer.
;; let's just kill the program here.
;; this is likely a copy-paste bug from get-process dead-pool-heap.
(break)
)
(cond
(proc
;; success! set our type and return.
(set! (-> (-> proc) type) type-to-make)
(the process (-> proc)) ;; cast from process-tree to process.
)
(else
(format 0 "WARNING: ~A ~A could not be allocated, because ~A was empty.~%"
type-to-make (ppointer->process proc) (-> this name))
(the process #f)
)
)
)
)
(defmethod return-process dead-pool ((this dead-pool) (proc process))
"Return a process to its pool once you are done with it."
(change-parent proc this)
(none)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Dead Pool Heap
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; a dead-pool-heap is a chunk of memory where you can allocate variable sized processes.
;; these processes start out with a lot of memory, then shrink their heap (compact) to the size
;; they actually need. To avoid heap fragmentation, the dead-pool-heap system will relocate
;; processes. This requires that you implement the relocate method on your process.
;; DANGER: the dead pool heap is _not_ a proper process tree. Do not attempt to treat it like one.
;; If you get-process, you should immediately activate it. The activate method will (change-parent)
;; and this will get stuck in an endless loop if you do it on a process that wasn't the most recent one.
(define-extern *null-process* process)
(defmethod new dead-pool-heap ((allocation symbol) (type-to-make type) (name basic) (allocated-length int) (heap-size int))
"Create a new dead pool heap. It will support allocated-length processes and have a total heap size of heap-size"
(let ((this (object-new allocation type-to-make (+ (the int (-> type-to-make size))
(the int (align16 (* allocated-length 12)))
heap-size))))
(set! (-> this name) name)
(set! (-> this mask) (process-mask process-tree))
(set! (-> this allocated-length) allocated-length)
(set! (-> this parent) #f)
(set! (-> this brother) #f)
(set! (-> this child) #f)
(set! (-> this self) this)
(set! (-> this ppointer) (the (pointer process) (&-> this self)))
;; initialize each process handle
;; build them into a linked list of null-process
(countdown (i allocated-length)
(let ((rec (-> this process-list i)))
(set! (-> rec process) *null-process*)
(set! (-> rec next) (-> this process-list (+ i 1)))
)
)
;; set up the dead-list
(set! (-> this dead-list next) (-> this process-list 0))
(set! (-> this alive-list process) #f) ;; likely typo here, should be dead-list
(set! (-> this process-list (- allocated-length 1) next) #f)
;; nothing is alive
(set! (-> this last) (-> 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)
;; setup the heap. It just begins after the process records.
(set! (-> this heap base) (the pointer (align16 (-> this process-list allocated-length))))
(set! (-> this heap current) (-> this heap base))
(set! (-> this heap top) (&+ (-> this heap base) heap-size))
(set! (-> this heap top-base) (-> this heap top))
this
)
)
(defmethod gap-location dead-pool-heap ((this dead-pool-heap) (rec dead-pool-heap-rec))
"Get the gap after the given process.
If root of the alive list is given, will give the first gap between the heap and the first process.
If there is no gap, may point to the next process. Not 16-byte aligned."
(cond
((-> rec process)
(the pointer (&+ (-> rec process) (-> process size) (-> rec process allocated-length) (- *gtype-basic-offset*)))
;; start of proc end of type data process's heap basic offset
)
(else
(-> this heap base)
)
)
)
(defmethod gap-size dead-pool-heap ((this dead-pool-heap) (rec dead-pool-heap-rec))
"Determine the size between the given process and the next process or end of the heap.
If you give the first rec, it will given the gap between the beginning of the heap and the next process."
(the int
(cond
((-> rec process)
;; compute the end of my process (no basic offset)
(let ((my-end (&+ (-> rec process) (-> process size) (-> rec process allocated-length))))
(if (-> rec next)
;; if there's a next process, look at the difference to the next (basic offsets cancel)
(&- (-> rec next process) my-end)
;; no next process, look at the top of the heap.
(&- (-> this heap top) (&+ my-end *gtype-basic-offset*))
)
)
)
(else
(if (-> rec next)
(&- (-> rec next process) (&+ (-> this heap base) *gtype-basic-offset*))
(&- (-> this heap top) (-> this heap base)))
)
)
)
)
(defmethod find-gap dead-pool-heap ((this dead-pool-heap) (rec dead-pool-heap-rec))
"Start at the given record and find the closest gap after it. Returns the rec
which has the gap after it. If no gaps, returns the last rec."
(while (and (-> rec next) (zero? (gap-size this rec)))
; no gap here!
(set! rec (-> rec next))
)
rec
)
(defmethod inspect dead-pool-heap ((this dead-pool-heap))
"Inspect a dead-pool-heap and all of the recs and their gaps"
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~Tname: ~A~%" (-> this name))
(format #t "~Tmask: ~D~%" (-> this mask))
(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 last))
(format #t "~Tdead-list: #<dead-pool-heap-rec @ #x~X>~%" (-> this dead-list))
;; here we consider the free memory to be all of the stuff after the last process.
;; we don't consider random gaps to be "free".
;; this means you can do a single allocation of free bytes and it will always succeed.
(let* ((total (the int (&- (-> this heap top) (-> this heap base))))
(free (if (-> this last)
(gap-size this (-> this last))
total))
)
(format #t "~Tprocess-list[0] @ #x~X ~D/~D bytes used~%" (-> this process-list) (- total free) total)
)
(let ((rec (-> this alive-list))
(i 0)
)
(while rec
(when (-> rec process)
(format #t "~T [~3D] #<dead-pool-heap-rec @ #x~X> ~A~%" i rec (-> rec process))
)
(let ((gap (gap-size this rec)))
(unless (zero? gap)
(format #t "~T gap: ~D bytes @ #x~X~%" gap (gap-location this rec)))
)
(set! rec (-> rec next))
(+! i 1)
)
)
this)
(defmethod asize-of dead-pool-heap ((this dead-pool-heap))
"Get our total size. Uses the heap top as the end."
(- (the int (-> this heap top)) (the int this) *gtype-basic-offset*)
)
(defmethod memory-used dead-pool-heap ((this dead-pool-heap))
"Get the amount of memory used. This includes gaps between processes."
(if (-> this last)
; we have at least one process, get the not-last-gap memory
(- (memory-total this) (gap-size this (-> this last)))
; no processes.
0
)
)
(defmethod memory-total dead-pool-heap ((this dead-pool-heap))
"Get the total amount of memory for processes"
(the int (&- (-> this heap top) (-> this heap base)))
)
(defmethod memory-free dead-pool-heap ((this dead-pool-heap))
"Get the total memory free."
(let ((top (-> this heap top)))
(if (-> this last)
; get the last gap size
(gap-size this (-> this last))
; otherwise just the whole heap.
(the int (&- top (-> this heap base)))
)
)
)
(defmethod compact-time dead-pool-heap ((this dead-pool-heap))
"Access the compact time field."
(-> this compact-time)
)
(defmethod find-gap-by-size dead-pool-heap ((this dead-pool-heap) (size int))
"Find a gap which will fit at least size bytes. Returns the rec for the proc before the gap.
Will return a #f rec if there's no gap big enough."
; start our search at first-gap
(let ((rec (-> this first-gap)))
(while (and rec (< (gap-size this rec) size))
;; nope, not big enough.
(set! rec (-> rec next))
)
rec
)
)
;; this will be set to #t if we're using visibility data.
;; if we aren't, there will be many cases where we try to spawn too many actors, and we shouldn't
;; warn when this happens.
(define-extern *vis-boot* basic)
(defmethod get-process dead-pool-heap ((this dead-pool-heap) (type-to-make type) (stack-size int))
"Allocate a process"
;; get a record for the new process
(let ((rec (-> this dead-list next))
;; will eventually hold our new process
(proc (the process #f))
;; find the rec which has a big enough gap
(insert (find-gap-by-size this (+ (the int (-> process size)) stack-size)))
)
(cond
;; check we got both a record and a gap
((and rec insert)
;; pop the record off of the list
(set! (-> this dead-list next) (-> rec next))
;; splice it into the alive list in the right spot
(let ((next (-> insert next)))
;; after the gap rec
(set! (-> insert next) rec)
;; us to the process after the gap
(set! (-> rec next) next)
;; link the proc after us back
(when next
(set! (-> next prev) rec)
)
;; and us back to the proc before the gap
(set! (-> rec prev) insert)
;; if we are inserting after the last process, we should update the last.
(when (eq? insert (-> this last))
(set! (-> this last) rec)
)
;; get the gap
(set! proc (the process (gap-location this insert)))
;; and allocate! The method new does the offset for us.
(set! proc ((method-of-type process new) (the symbol proc) process 'process stack-size))
;; update our rec to contain this process.
(set! (-> rec process) proc)
;; and the ppointer should point to the rec, not the processs, so we can track the process if it moves.
(set! (-> proc ppointer) (&-> rec process))
;; if we used the first gap, update first gap
(when (eq? (-> this first-gap) insert)
(set! (-> this first-gap) (find-gap this rec))
)
;; we haven't shrunk yet. If we don't have a first-shrink, or we are before it,
;; mark us as first shrink.
(when (or (not (-> this first-shrink))
(< (the int proc) (the int (-> this first-shrink process)))
)
(set! (-> this first-shrink) rec)
)
;; update tree stuff.
(set! (-> proc parent) (-> this ppointer))
(set! (-> proc pool) this)
(set! (-> this child) (&-> rec process))
)
)
(else
;; allocation failed! try again on the debug heap if we're debugging.
(when (and *debug-segment* (not (eq? this *debug-dead-pool*)))
(set! proc (get-process *debug-dead-pool* type-to-make stack-size))
(when (and proc *vis-boot*)
(format 0 "WARNING: ~A ~A had to be allocated from the debug pool, because ~A was empty.~%" type-to-make proc (-> this name)))
)
)
)
(cond
(proc
;; success! set type and return.
(set! (-> proc type) type-to-make)
)
(else
;; failure. complain.
(format 0 "WARNING: ~A ~A could not be allocated, because ~A was empty.~%" type-to-make proc (-> this name))
)
)
proc)
)
(defmethod return-process dead-pool-heap ((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 dead-pool-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
)
(defmethod compact dead-pool-heap ((this dead-pool-heap) (count int))
"Do heap compaction. The count argument tells us how much work to do.
If the heap is very full we will automatically do more work than requested."
;; first we see how much memory is in use.
(let ((free (memory-free this))
(total (memory-total this))
)
(let ((perc (/ (the float free) (the float total))))
(cond
((< perc 0.1)
;; 90% full! set count very large to try to fix this and complain.
(set! count 1000)
(when (and *debug-segment* (-> *kernel-context* low-memory-message))
(format *stdcon* "~3LLow Actor Memory~%~0L")
)
)
((< perc 0.2)
;; 80% full, try 4x harder
(set! count (* count 4))
)
((< perc 0.3)
;; 70% full, try 2x harder
(set! count (* count 2))
)
)
)
)
;; update stats
(set! (-> this compact-count-targ) count)
(set! (-> this compact-count) 0)
;; and do compaction!
(countdown (ii count)
;; first try to shrink a heap.
(let ((shrink (-> this first-shrink)))
(when (not shrink)
;; not sure when this happens, but reset shrink if we need to.
(set! shrink (set! (-> this first-shrink) (-> this alive-list next)))
)
(when shrink
;; do a shrink!
(shrink-heap this (-> shrink process))
)
)
;; now find the first gap
(let ((gap (-> this first-gap)))
;; and the thing after it
(when (-> gap next)
(let ((proc (-> gap next process))
(size (gap-size this gap)))
(unless (zero? size)
;;(format #t "[kernel] Relocating process ~A by ~D.~%" proc (- size))
(when (< size 0)
;; bug!
(break)
)
;; try shrinking before relocating.
(shrink-heap this proc)
;; relocate!
(relocate proc (- size))
;; update first gap
(set! (-> this first-gap) (find-gap this gap))
;; and update stats.
(+! (-> this compact-count) 1)
)
)
)
)
)
(none)
)
(defmethod churn dead-pool-heap ((this dead-pool-heap) (count int))
"Mess with the heap"
(countdown (ii count)
(let ((rec (-> this alive-list next)))
(when rec
(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)))
(when (eq? (-> this first-shrink) rec)
(set! (-> this first-shrink) (-> rec prev))
(when (not (-> this first-shrink process))
(set! (-> this first-shrink) #f))
)
(set! (-> rec prev next) (-> rec next))
(cond
((-> rec next)
(set! (-> rec next prev) (-> rec prev))
)
(else
(set! (-> this last) (-> rec prev))
)
)
(let* ((insert (-> this last))
(next (-> insert next))
)
(set! (-> insert next) rec)
(set! (-> rec next) next)
(when next
(set! (-> next prev) rec))
(set! (-> rec prev) insert)
(set! (-> this last) rec)
(set! (-> rec process) (relocate (-> rec process) (the int (&- (gap-location this insert)
(the int (&- (-> rec process) *gtype-basic-offset*))))))
)
)
)
)
(none)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Finding
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GOAL lambdas aren't real lambdas, so you have to do this.
(define *global-search-name* (the basic #f))
(define *global-search-count* 0)
(define-extern search-process-tree (function process-tree (function process-tree object) process))
(define-extern iterate-process-tree (function process-tree (function object object) kernel-context object))
(define-extern execute-process-tree (function process-tree (function object object) kernel-context object))
(defun process-by-name (name (pool process-tree))
"Look up a process in the given pool by name"
(set! *global-search-name* (the basic name))
(search-process-tree pool (lambda ((var process)) (name= (-> var name) *global-search-name*)))
)
(defun process-not-name (name (pool process-tree))
"Look up a process with not the given name."
(set! *global-search-name* (the basic name))
(search-process-tree pool (lambda ((var process)) (not (name= (-> var name) *global-search-name*))))
)
(defun process-count ((this process-tree))
"Count number of processes in the given tree using iterate-process-tree"
(set! *global-search-count* 0)
(iterate-process-tree this
(lambda ((this process))
(+! *global-search-count* 1)
#t)
*null-kernel-context*)
*global-search-count*)
(defun kill-by-name (name (pool process-tree))
"Call deactivate on all process with the given name."
(let ((proc (the process-tree #f)))
(while (set! proc (process-by-name name pool))
(deactivate proc)
)
)
)
(defun kill-by-type (type (pool process-tree))
"Call deactivate on all processes with the given type"
(set! *global-search-name* (the basic type))
(let ((proc (the process #f)))
(while (set! proc (search-process-tree pool (lambda ((var process))
(= (the type *global-search-name*)
(-> var type)))))
(deactivate proc)
)
)
)
(defun kill-not-name (name (pool process-tree))
"Call deactivate on all processes that don't match the name"
(let ((proc (the process-tree #f)))
(while (set! proc (process-not-name name pool))
(deactivate proc)
)
)
)
(defun kill-not-type (type (pool process-tree))
"Call deactivate on all prcesses that don't match the given type"
(set! *global-search-name* (the basic type))
(let ((proc (the process-tree #f)))
(while (set! proc (search-process-tree pool (lambda ((var process))
(!= (the type *global-search-name*)
(-> var type)))))
(deactivate proc)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Iterating
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod run-logic? process ((this process))
"Return if the process should be run or not.
Children of process should override this with more interesting functions"
#t)
;; the following three functions recursively iterate through process trees.
(defun iterate-process-tree ((this process-tree) (func (function object object)) (context kernel-context))
"Call func on all processes that aren't a process-tree. If func returns 'dead, stop.
The kernel-context is ignored."
(let ((ret (or (process-mask? (-> this mask) process-tree)
(func this))))
(cond
((eq? ret 'dead)
;; stop.
)
(else
;; iterate through brothers
(let ((brother (-> this child)))
(while brother
;; kinda weird, we use the brother from _before_ recursing.
(let ((old-brother (-> (-> brother) brother)))
(iterate-process-tree (-> brother) func context)
(set! brother old-brother)
)
)
)
)
)
ret
)
)
(defun execute-process-tree ((this process-tree) (func (function object object)) (context kernel-context))
"Like iterate, but also requires that prevent-from-run's mask doesn't block, and that run-logic?
is true in order to call the function."
;; check mask for tree, mask for prevent, run-logic?, then run!
(let ((ret (or (process-mask? (-> this mask) process-tree)
(not (and (or (zero? (logand (-> context prevent-from-run) (-> this mask))))
(run-logic? this)))
(func this)
)))
;; run on our children
(cond
((eq? ret 'dead) ;; if dead, don't bother checking children.
)
(else (let ((brother (-> this child)))
(while brother
(let ((temp (-> (-> brother) brother)))
(execute-process-tree (-> brother) func context)
(set! brother temp))
)
)
)
)
ret)
)
(defun search-process-tree ((this process-tree) (func (function process-tree object)))
"Find the first process which func return true on. Won't find process-tree's (by mask)"
;; reject process-tree
(unless (process-mask? (-> this mask) process-tree)
;; is this a match?
(when (func this)
(return (the process this))
)
)
;; not a match, check out children
(let ((brother (-> this child)))
(while brother
(let ((temp (-> (-> brother) brother)))
(let ((ret (search-process-tree (-> brother) func)))
(when ret
(return ret)
)
)
(set! brother temp)
)
)
)
(the process #f)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Kernel Dispatcher
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro process-name-as-string (proc)
`(let ((proc-type (-> ,proc name type)))
(cond
((= proc-type string)
(the string (-> ,proc name))
)
((= proc-type symbol)
(symbol->string (-> ,proc name))
)
(else
"??"
)
)
)
)
(define-extern *listener-process* process)
(define-extern *active-pool* process-tree)
(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!
;; 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)
)
;; iterate over all processes, running this lambda:
(execute-process-tree
*active-pool*
(lambda ((this process))
(let ((context *kernel-context*))
(cond
((or (eq? (-> this status) 'waiting-to-run)
(eq? (-> this status) 'suspended))
;; begin event in profiler.
(profiler-start-event (process-name-as-string this))
;; set current process to us
(set! (-> context current-process) this)
;; pause tricks to prevent debug text and drawings from disappearing when pausing:
(cond
((process-mask? (-> this mask) pause)
;; we are a pausable object, so we should put our *stdcon* to the one that isn't cleared during pause:
(set! *stdcon* *stdcon1*)
;; and we should do our debug drawing to a buffer that isn't cleared during pause:
(set! *debug-draw-pauseable* #t)
)
(else
;; non-pausable, use the *stdcon* that's cleared each time
(set! *stdcon* *stdcon0*)
;; and don't debug draw to a buffer
(set! *debug-draw-pauseable* #f)
)
)
;; TRANS
;; this function should run before resuming.
(cond
((-> this trans-hook)
;; we have a trans hook defined. let's create a thread and run it. we can reuse the stack of the main-thread
;; it is safe to do this because the main-thread is currently suspended or hasn't run yet.
(let ((trans (new 'process 'cpu-thread this 'trans PROCESS_STACK_SAVE_SIZE (-> this main-thread stack-top))))
;; call the function in the thread.
(reset-and-call trans (-> this trans-hook))
(#when KERNEL_DEBUG
(when (!= (-> trans type) cpu-thread)
(format 0 "corrupted stack after trans for ~A~%" this)
)
)
;; remove the cpu-thread
(delete trans)
;; check for deadness
(when (eq? (-> this status) 'dead)
(set! (-> context current-process) #f)
(profiler-end-event)
(return 'dead) ;; tells the execute-process-tree function to skip our children.
)
)
)
)
;; MAIN CODE
(if (process-mask? (-> this mask) sleep-code)
;; we're sleeping. Move us to suspended, in case we were in waiting to run.
(set! (-> this status) 'suspended)
;; not sleeping. call resume hook. This will return once the main thread suspends again.
((-> this main-thread resume-hook) (-> this main-thread))
)
;; check for deadness
(cond
((eq? (-> this status) 'dead)
;; oops we died. return 'dead
(set! (-> context current-process) #f)
(profiler-end-event)
'dead
)
(else
;; not dead.
;; POST CODE
(cond
((-> this post-hook)
;; Note: use dram stack always. This will allow actors to use the scratchpad stack and get a speedup for trans/code
;; but still be able to do joint-animation stuff that uses the scratchpad in post.
(let ((post (new 'process 'cpu-thread this 'post PROCESS_STACK_SAVE_SIZE *kernel-dram-stack*)))
(reset-and-call post (-> this post-hook))
(delete post)
(when (eq? (-> this status) 'dead)
;; oops we died.
(set! (-> context current-process) #f)
(profiler-end-event)
(return 'dead)
)
(set! (-> this status) 'suspended)
)
)
)
(set! (-> context current-process) #f)
(profiler-end-event)
#f
)
)
)
((eq? (-> this status) 'dead)
'dead)
)
)
)
*kernel-context*
)
)
(define-extern inspect-process-tree (function process-tree int int symbol process-tree))
(defun inspect-process-tree ((this process-tree) (level int) (mask int) (detail symbol))
"Debug print a pocess-tree"
(print-tree-bitmask mask (+ 0 level))
;; print us
(cond
(detail
(format #t "__________________~%")
;; this is here, but I removed it because it prints at the wrong indent and looks weird.
;(format #t "~S~A~%" (if (zero? level) "" "+---") this)
(protect (*print-column*)
(set! *print-column* (the binteger (* level 4)))
(inspect this)
)
)
(else
(format #t "~S~A~%" (if (zero? level) "" "+---") this)
)
)
;; print our children
(let ((child (-> this child)))
(while child
(inspect-process-tree (-> child) (+ level 1) (if (not (-> (-> child) brother)) mask (logior mask (ash 1 (+ 1 level)))) detail)
(set! child (-> (-> child) brother))
)
)
this
)
(defmacro set-u128-as-u64! (dst src)
`(set! (-> (the (pointer uint64) (& ,dst)))
,src
)
)
(defmacro set-u64-from-u128! (dst src)
`(set! ,dst (-> (the (pointer uint64) (& ,src))))
)
(defmacro the-super-u64-fucntion (func)
`(the-as (function uint uint uint uint uint uint object) ,func)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Stack Frame Stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The GOAL kernel supports dynamic throw and catch.
;; The catch frames are managed per process (you can't throw to a frame outside your process)
;; But otherwise it is fully dynamic.
(defmethod new catch-frame ((allocation symbol) (type-to-make type) (name symbol) (func function) (param-block (pointer uint64)))
"Run func in a catch frame with the given 8 parameters.
The return value is the result of the function.
The allocation must be an address.
Unlike the original, this only works on the first six parameters, but I think this doesn't matter."
(declare (asm-func object)
(allow-saved-regs) ;; very dangerous!
)
(rlet ((pp :reg r13 :type process)
(temp :reg rax :type uint)
(off :reg r15 :type uint)
(sp :reg rsp :type uint)
(s0 :reg rbx :type uint)
(s1 :reg rbp :type uint)
(s2 :reg r10 :type (pointer uint64))
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint)
(xmm8 :reg xmm8 :class fpr)
(xmm9 :reg xmm9 :class fpr)
(xmm10 :reg xmm10 :class fpr)
(xmm11 :reg xmm11 :class fpr)
(xmm12 :reg xmm12 :class fpr)
(xmm13 :reg xmm13 :class fpr)
(xmm14 :reg xmm14 :class fpr)
(xmm15 :reg xmm15 :class fpr)
)
;; we treat the allocation as an address.
(let ((this (the catch-frame (&+ allocation *gtype-basic-offset*))))
;; setup catch frame
(set! (-> this type) type-to-make)
(set! (-> this name) name)
;; get the return address (the compiler won't touch the stack because we're an asm-func)
(.pop temp)
(.push temp)
;; make it a GOAL address so it fits in 32 bits
(.sub temp off)
;; store it
(set! (-> this ra) (the int temp))
;; todo, do we need a stack offset here?
;; remember the stack pointer
(set! temp sp)
(.sub temp off)
(set! (-> this sp) (the int temp))
;; back up registers we care about
(.mov :color #f temp s0)
(set-u128-as-u64! (-> this rreg 0) temp)
(.mov :color #f temp s1)
(set-u128-as-u64! (-> this rreg 1) temp)
(.mov :color #f temp s2)
(set-u128-as-u64! (-> this rreg 2) temp)
(.mov :color #f temp s3)
(set-u128-as-u64! (-> this rreg 3) temp)
(.mov :color #f temp s4)
(set-u128-as-u64! (-> this rreg 4) temp)
(.mov :color #f temp xmm8)
(set! (-> this freg 0) (the-as float temp))
(.mov :color #f temp xmm9)
(set! (-> this freg 1) (the-as float temp))
(.mov :color #f temp xmm10)
(set! (-> this freg 2) (the-as float temp))
(.mov :color #f temp xmm11)
(set! (-> this freg 3) (the-as float temp))
(.mov :color #f temp xmm12)
(set! (-> this freg 4) (the-as float temp))
(.mov :color #f temp xmm13)
(set! (-> this freg 5) (the-as float temp))
(.mov :color #f temp xmm14)
(set! (-> this freg 6) (the-as float temp))
(.mov :color #f temp xmm15)
(set! (-> this freg 7) (the-as float temp))
;; push this stack frame
(set! (-> this next) (-> pp stack-frame-top))
(set! (-> pp stack-frame-top) this)
;; help coloring, it isn't smart enough to realize it's "safe" to use these registers.
(.push :color #f s3)
(.push :color #f s2)
(.push :color #f s2)
(set! s3 (the uint func))
(set! s2 param-block)
;; todo - are we aligned correctly here?
(let ((ret ((the-super-u64-fucntion s3)
(-> s2 0)
(-> s2 1)
(-> s2 2)
(-> s2 3)
(-> s2 4)
(-> s2 5)
))
)
(.pop :color #f s2)
(.pop :color #f s2)
(.pop :color #f s3)
(set! (-> pp stack-frame-top) (-> pp stack-frame-top next))
(.ret)
(the object ret)
)
)
)
)
(defun throw-dispatch ((this catch-frame) value)
"Throw the given value to the catch frame.
Only can throw a 64-bit value. The original could throw 128 bits."
(declare (asm-func none))
(rlet ((pp :reg r13 :type process)
(temp :reg rax :type uint)
(off :reg r15 :type uint)
(sp :reg rsp :type uint)
(s0 :reg rbx :type uint)
(s1 :reg rbp :type uint)
(s2 :reg r10 :type (pointer uint64))
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint)
(temp-float :reg xmm0 :class fpr)
(xmm8 :reg xmm8 :class fpr)
(xmm9 :reg xmm9 :class fpr)
(xmm10 :reg xmm10 :class fpr)
(xmm11 :reg xmm11 :class fpr)
(xmm12 :reg xmm12 :class fpr)
(xmm13 :reg xmm13 :class fpr)
(xmm14 :reg xmm14 :class fpr)
(xmm15 :reg xmm15 :class fpr)
)
;; pop everything we threw past
(set! (-> pp stack-frame-top) (-> this next))
;; restore regs we care about.
(set-u64-from-u128! temp (-> this rreg 0))
(.mov :color #f s0 temp)
(set-u64-from-u128! temp (-> this rreg 1))
(.mov :color #f s1 temp)
(set-u64-from-u128! temp (-> this rreg 2))
(.mov :color #f s2 temp)
(set-u64-from-u128! temp (-> this rreg 3))
(.mov :color #f s3 temp)
(set-u64-from-u128! temp (-> this rreg 4))
(.mov :color #f s4 temp)
(set! temp-float (-> this freg 0))
(.mov :color #f xmm8 temp-float)
(set! temp-float (-> this freg 1))
(.mov :color #f xmm9 temp-float)
(set! temp-float (-> this freg 2))
(.mov :color #f xmm10 temp-float)
(set! temp-float (-> this freg 3))
(.mov :color #f xmm11 temp-float)
(set! temp-float (-> this freg 4))
(.mov :color #f xmm12 temp-float)
(set! temp-float (-> this freg 5))
(.mov :color #f xmm13 temp-float)
(set! temp-float (-> this freg 6))
(.mov :color #f xmm14 temp-float)
(set! temp-float (-> this freg 7))
(.mov :color #f xmm15 temp-float)
;; set stack pointer
(set! sp (the uint (-> this sp)))
(.add sp off)
;; overwrite our return address
(.pop temp)
(set! temp (the uint (-> this ra)))
(.add temp off)
(.push temp)
;; load the return register
(.mov temp value)
(.ret)
)
)
(defun throw ((name symbol) value)
"Dynamic throw."
(rlet ((pp :reg r13 :type process))
(let ((cur (-> pp stack-frame-top)))
(while cur
(when (and (eq? (-> cur name) name) (eq? (-> cur type) catch-frame))
;; match!
(throw-dispatch (the catch-frame cur) value)
)
(if (eq? (-> cur type) protect-frame)
;; call the cleanup function
((-> (the protect-frame cur) exit))
)
(set! cur (-> cur next))
)
)
)
(format 0 "ERROR: throw could not find tag ~A~%" name)
(break)
)
(defmethod new protect-frame ((allocation symbol) (type-to-make type) (func (function object)))
(let ((this (the protect-frame (&+ allocation *gtype-basic-offset*))))
(set! (-> this type) type-to-make)
(set! (-> this name) 'protect-frame)
(set! (-> this exit) func)
(rlet ((pp :reg r13 :type process))
(set! (-> this next) (-> pp stack-frame-top))
(set! (-> pp stack-frame-top) this)
)
this
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tree Stuff
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun previous-brother ((proc process-tree))
"Get the process p where (-> p brother) is proc. Unused"
(local-vars (parent (pointer process-tree))
(child (pointer process-tree))
)
;; look up the tree to find our parent
(set! parent (-> proc parent))
(the-as process-tree
(when parent
;; make sure we aren't the only child.
(set! child (-> parent 0 child))
(if (= child proc) (return '#f))
;; iterate, until we find the one.
(while child
(if (= (-> child 0 brother) proc) (return child))
(set! child (-> child 0 brother))
)
;; nope, didn't find it. bad tree.
'#f
)
)
)
(defun change-parent ((this process-tree) (new-parent process-tree))
"Make this a child of new-parent"
(let ((parent (-> this parent)))
;; parent is a ppointer.
;; need to remove this from its current parent
(when parent
(let ((proc (-> (-> parent) child)))
(if (eq? (ppointer->process proc) this)
;; case where we're the first child is easy!
(set! (-> (-> parent) child) (-> this brother))
;; otherwise, look through brothers to find us.
(begin
(while (not (eq? (ppointer->process (-> (-> proc) brother)) this))
(set! proc (-> (-> proc) brother))
)
;; ok, got us, splice out of list.
(set! (-> (-> proc) brother) (-> this brother))
)
)
)
)
;; add to new parent
(set! (-> this parent) (-> new-parent ppointer))
(set! (-> this brother) (-> new-parent child))
(set! (-> new-parent child) (-> this ppointer))
this
)
)
(defun change-brother ((arg0 process-tree) (arg1 process-tree))
"Unused, and wrong.
It seems like this was written when processes store process-trees, not (pointer process-tree)."
(local-vars
(v1-4 (pointer process-tree))
(a1-1 symbol)
(a2-1 (pointer process-tree))
(a3-1 (pointer process-tree))
(t0-0 (pointer process-tree))
(t1-0 (pointer process-tree))
(t1-3 (pointer process-tree))
(t1-4 (pointer process-tree))
(t1-7 (pointer process-tree))
(t1-8 (pointer process-tree))
(t1-12 (pointer process-tree))
(t1-13 (pointer process-tree))
(t1-17 (pointer process-tree))
)
(when (and arg0 (!= (-> arg0 brother) arg1) (!= arg0 arg1))
(set! a2-1 (-> arg0 parent))
(when a2-1
(set! t0-0 (-> a2-1 0 child))
(set! a3-1 '#f)
(set! v1-4 '#f)
(set! t1-0 t0-0)
(when (= (if t1-0 (-> t1-0 0 self)) arg0)
(set! a3-1 a2-1)
(set! t1-3 a3-1)
)
(set! t1-4 t0-0)
(when (= (if t1-4 (-> t1-4 0 self)) arg1)
(set! v1-4 a2-1)
(set! t1-7 v1-4)
)
(while (and (-> t0-0 0 brother) (or (not a3-1) (not v1-4)))
(set! t1-8 t0-0)
(when (= (-> (if t1-8 (-> t1-8 0 self)) brother) arg1)
(set! v1-4 t0-0)
(set! t1-12 v1-4)
)
(set! t1-13 t0-0)
(when (= (-> (if t1-13 (-> t1-13 0 self)) brother) arg0)
(set! a3-1 t0-0)
(set! t1-17 a3-1)
)
(set! t0-0 (-> t0-0 0 brother))
)
(if (or (not a3-1) (not v1-4))
(return 0)
(if (= a3-1 a2-1)
(set! (-> a3-1 4) (the process-tree (-> arg0 brother))) ;; wrong
(set! (-> a3-1 3) (the process-tree (-> arg0 brother))) ;; wrong
)
)
(cond
((= v1-4 a2-1)
(set! (-> arg0 brother) (the (pointer process-tree) (-> v1-4 4))) ;; wrong
(set! (-> v1-4 4) (the process-tree (-> arg0 ppointer))) ;; wrong
)
(else
(set! (-> arg0 brother) (the (pointer process-tree) (-> v1-4 3)))
(set! (-> v1-4 3) (the process-tree (-> arg0 ppointer)))
)
)
)
)
(the-as process-tree arg0)
)
(defun change-to-last-brother ((arg0 process-tree))
(local-vars
(v1-4 (pointer process-tree))
(v1-8 symbol)
(a1-0 (pointer process-tree))
(a1-5 symbol)
(a1-9 symbol)
)
(when (and (-> arg0 brother) (-> arg0 parent))
(set! a1-0 (-> arg0 parent))
(set! 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) '#f)
)
arg0
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Control
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod activate process ((this process) (dest process-tree) (name basic) (stack-top pointer))
"Activate a process! Put it on the given active tree and set up the main thread."
;; if we got the scratchpad stack, move to the fake scratchpad.
(#when PC_PORT
(when (= stack-top *scratch-memory-top*)
(set! stack-top (&+ *fake-scratchpad-stack* (* 32 1024)))
)
)
;; inherit mask (minus stuff like sleep)
(set! (-> this mask) (logand (-> dest mask) PROCESS_CLEAR_MASK))
(set! (-> this status) 'ready)
;; get a unique pid.
(let ((pid (-> *kernel-context* next-pid)))
(set! (-> this pid) pid)
(set! (-> *kernel-context* next-pid) (+ 1 pid)))
(set! (-> this top-thread) #f)
(set! (-> this main-thread) #f)
(set! (-> this name) name)
;; set up our heap. Note that we apply an offset of heap-base to leave room for fields of the actual type.
;; unclear why we can't just use the size of our type... but I guess this gives you the option
;; to put some other stuff in between the fields and the heap.
(set! (-> this heap-base) (set! (-> this heap-cur) (&+ (-> this stack) (-> this type heap-base))))
(set! (-> this stack-frame-top) #f)
;; heaps should be 0 initialized.
(mem-set32! (-> this stack) (the int (/ (-> this type heap-base) 4)) 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)
;; inherit entity if our parent is another process
(if (process-mask? (-> dest mask) process-tree)
(set! (-> this entity) #f)
(set! (-> this entity) (-> (the process dest) entity))
)
;; reset all connections
(set! (-> this connection-list next1) #f)
(set! (-> this connection-list prev1) #f)
;; allocate the main thread (sets everything up.)
(let ((thread (new 'process 'cpu-thread this 'code PROCESS_STACK_SAVE_SIZE stack-top)))
(set! (-> this main-thread) thread)
)
(change-parent this dest)
)
(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!"
(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)
)
)
(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)
)
)
(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))
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Deactivation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod deactivate process-tree ((this process-tree))
"Can't deactivate a 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))
;; this is not yet defined.
(define entity-deactivate-handler (the (function process entity-actor none) nothing))
(define-extern process-disconnect (function process int))
(defmethod deactivate process ((this process))
"Deactivate a process. This returns the process to the dead pool
it came from. You can use this on your own process to kill yourself
and immediately return to the kernel.
You can also use this during initialization to kill yourself and return
to the process that initialzed you.
All protects/states will be cleaned up, with pp set correctly for the process.
But you might not have the stack of your main thread, so don't reference stack
vars from within your exit handlers."
;; don't do anything if we already died.
(unless (eq? (-> this status) 'dead)
;; set our state to a dead-state that does nothing.
(set! (-> this next-state) dead-state)
;; call entity handler if we're from an entity.
(when (-> this entity)
(entity-deactivate-handler this (-> this entity))
)
;; clean up stack frames the process is in.
;; first, set pp so the cleanup code thinks its running in the right process.
;; we might be getting deactivated from another process.
(rlet ((pp :reg r13 :type process))
(let ((old-pp pp))
(set! pp this)
(let ((cur (-> pp stack-frame-top)))
;; loop over frames...
(while cur
(case (-> cur type)
((protect-frame state)
;; we're a state or protect-frame, we can exit.
((-> (the-as protect-frame cur) exit))
)
)
(set! cur (-> cur next))
)
)
(set! pp old-pp)
)
)
;; remove our connections.
;; hack - if this isn't defined yet, don't try it.
(if (!= 0 (the uint process-disconnect))
(process-disconnect this)
)
;; kill our child and their brothers
(let ((bro (-> this child)))
(while bro
(let ((temp (-> (-> bro) brother)))
(deactivate (-> bro))
(set! bro temp)
)
)
)
;; return ourself to the pool
(return-process (-> this pool) this)
(set! (-> this state) #f)
(set! (-> this next-state) #f)
(set! (-> this entity) #f)
(set! (-> this pid) 0)
;; deal with getting out of here.
(cond
;; first case - we deactivated the running process
;; (note, we don't check against pp because run-function-in-process
;; will change pp for running initializations.)
((eq? this (-> *kernel-context* current-process))
;; go straight to dead.
(set! (-> this status) 'dead)
;; and return (with no deactivate)
;; TODO: replace with abandon.
(let ((temp (the uint return-from-thread)))
(rlet ((off :reg r15 :type uint))
(+! temp off)
(.push temp)
(.ret)
)
)
)
;; second case - we deactivated while initializing.
((eq? (-> this status) 'initialize)
(set! (-> this status) 'dead)
;; throw back to the place where we started initializing.
(throw 'initialize #f)
)
)
(set! (-> this status) 'dead)
)
(none)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Globals
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the listener process is used to run functions 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*))
)
;; a dummy process for process records that don't have a process to point to.
;; it has a PID of 0, which matches nothing so the handle->process will return #f if the
;; ppointer points to this
(define *null-process* (new 'global 'process 'listener 16))
;; do we have visibility data? level.gc will set this once we do, and once that happens, we expect
;; actors to fit in the non-debug heap.
(define *vis-boot* #f)
;; a few pools of fixed size processes that are shared.
(define *16k-dead-pool* (new 'global 'dead-pool 1 (* 16 1024) '*16k-dead-pool*))
(define *8k-dead-pool* (new 'global 'dead-pool 1 (* 8 1024) '*8k-dead-pool*))
(define *4k-dead-pool* (new 'global 'dead-pool 4 (* 4 1024) '*4k-dead-pool*))
;; some very important process pools
(define *target-dead-pool* (new 'global 'dead-pool 1 (* 48 1024) '*target-dead-pool*))
(define *camera-dead-pool* (new 'global 'dead-pool 7 (* 4 1024) '*camera-dead-pool*))
(define *camera-master-dead-pool* (new 'global 'dead-pool 1 (* 8 1024) '*camera-master-dead-pool*))
;; used if other pools run out of space in debug mode
(if *debug-segment*
(define *debug-dead-pool* (new 'debug 'dead-pool-heap '*debug-dead-pool* 768 (* 1024 1024)))
)
;; variable sized actor pool (most actors go here)
(define *nk-dead-pool* (new 'global 'dead-pool-heap '*nk-dead-pool* (* PROCESS_HEAP_MULT 768) PROCESS_HEAP_SIZE))
;; use the nk-dead-pool in most places
(define *default-dead-pool* (the dead-pool *nk-dead-pool*))
(define *pickup-dead-pool* (the dead-pool *nk-dead-pool*))
;; list of all dead pools held by the kernel.
(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*))
;; main active pool. All active processes are under here. This is what the kernel-dispatcher looks at.
(define *active-pool* (new 'global 'process-tree 'active-pool))
;; create pools within *active-pool*
;; the *display-pool* will contain the display process which does rendering, vsync, and many per-frame updates.
(change-parent (define *display-pool* (new 'global 'process-tree 'display-pool)) *active-pool*)
;; the *camera-pool* will contain all cameras
(change-parent (define *camera-pool* (new 'global 'process-tree 'camera-pool)) *active-pool*)
;; all cameras should pause in menus
(set! (-> *camera-pool* mask) (process-mask pause menu progress camera process-tree))
;; the *target-pool* will contain jak
(change-parent (define *target-pool* (new 'global 'process-tree 'target-pool)) *active-pool*)
;; pause in menus
(set! (-> *target-pool* mask) (process-mask pause menu progress process-tree))
;; the *entity-pool* contains all processes spawned from entities.
(change-parent (define *entity-pool* (new 'global 'process-tree 'entity-pool)) *active-pool*)
(set! (-> *entity-pool* mask) (process-mask pause menu progress entity process-tree))
;; the *default-pool* is used for processes that don't fall into the others.
(change-parent (define *default-pool* (new 'global 'process-tree 'default-pool)) *active-pool*)
(set! (-> *default-pool* mask) (process-mask pause menu progress process-tree))
Reference in a new issue View git blame Copy permalink