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/kernel/gkernel.gc
water111 92afd62e2c
[decompiler] fix missing casts issue (#573) 
* fix casts issue

* fix bug

* one last small fix
2021-06-09 21:35:13 -04:00

2538 lines
86 KiB
Common Lisp
Raw Blame History

;;-*-Lisp-*-
(in-package goal)
;; name: gkernel.gc
;; name in dgo: gkernel
;; dgos: KERNEL
;; Fwd
(define-extern change-parent (function process-tree process-tree process-tree))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; System Globals
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; HACK ADDED
(define *use-old-listener-print* #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)
;; DebugBootLevel in C Kernel
(define *kernel-boot-level* (the symbol #f))
;; The number of DECI messages received.
;; The C Kernel increments this.
(define *deci-count* 0)
;; Some debug stats. Unused?
(define *last-loado-length* 0)
(define *last-loado-global-usage* 0)
(define *last-loado-debug-usage* 0)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Relocate
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Objects on a dynamic process heap may be relocated.
;; They should provide their own relocate method to do any fixups
;; for any references.
;; 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*)
;; #xf = OUTPUT_LOAD, OUTPUT_TRUE, EXECUTE, PRINT_LOGIN
(dgo-load package allocation #xf #x200000)
(set! *kernel-packages* (cons package *kernel-packages*))
)
)
(defun unload-package ((package string))
"Mark a package as unloaded, if it was loaded previously"
(let ((pack (nmember package *kernel-packages*)))
(when pack
(set! *kernel-packages* (delete! (car pack) *kernel-packages*))
)
*kernel-packages*
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Kernel Globals
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The kernel context is a global which stores the state of the kernel.
(define *kernel-context* (new 'static 'kernel-context
:prevent-from-run (process-mask execute sleep)
:next-pid 2
:current-process #f
:relocating-process #f
:low-memory-message #t
)
)
;; the main stack for running GOAL code!
;; all user code (that I know of) 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 (which wasn't used anyway)
(defconstant *kernel-dram-stack* (&+ *dram-stack* DPROCESS_STACK_SIZE))
;; I don't think this stack is used, but I'm not sure.
(set! (-> *kernel-context* fast-stack-top) *scratch-memory-top*)
;; A context with all process masks set to 0. This can be used to iterate through a process tree
;; without executing anything, to find a process for instance.
(define *null-kernel-context* (new 'static 'kernel-context))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Thread and CPU Thread
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; A GOAL thread represents the execution of code in a process.
;; Each process has a "main thread", which is suspended and resumed.
;; A process may also execute various temporary threads which always run until completion.
;; A "temporary thread" cannot suspend and resume, but a "main thread" can.
;; The currently executing thread of a process is the "top-thread".
;; 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 ((obj 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? obj (-> obj process main-thread))
;; We have attempted to delete the main thread, which is bad.
(break)
)
;; restore the old top-thread.
(set! (-> obj process top-thread) (-> obj previous))
(none)
)
(defmethod print thread ((obj thread))
"Print thread."
(format #t "#<~A ~S of ~S pc: #x~X @ #x~X>" (-> obj type) (-> obj name) (-> obj process name) (-> obj pc) obj)
obj)
(defmethod stack-size-set! thread ((this thread) (stack-size int))
"Set the backup stack size of a thread. This should only be done on the main-thread.
This should be done immediately after allocating the main-thread."
(let ((proc (-> this process)))
(cond
((neq? this (-> proc main-thread))
;; oops. can only change the size of a main-thread's stack.
(msg-err "illegal attempt change stack size of ~A when the main-thread is not the top-thread.~%" proc)
(break) ;; ADDED
)
((= (-> this stack-size) stack-size)
;; we already have this size. Don't do anything.
)
((eq? (-> proc heap-cur) (&+ this (-> this type size) (- *gtype-basic-offset*) (-> this stack-size)))
;; our heap cur point to right after us. So we can safely bump it forward to give us more space.
(set! (-> proc heap-cur) (the pointer (&+ this (-> this type size) (- *gtype-basic-offset*) stack-size)))
(set! (-> this stack-size) stack-size)
)
(else
(msg-err "illegal attempt change stack size of ~A after more heap allocation has occured.~%" proc)
)
)
)
(none)
)
(defmethod new cpu-thread ((allocation symbol) (type-to-make type) (parent-process process) (name symbol) (stack-size int) (stack-top pointer))
"Create a new CPU thread. 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* ((obj (cond
((-> parent-process top-thread)
;; we're allocating a temporary thread, the main thread already exists.
;; we can stash the cpu-thread structure at the bottom of the stack.
;; we use the smaller PROCESS_STACK_SIZE, which is only half the size of the real stack.
(the cpu-thread (&+ stack-top
(- PROCESS_STACK_SIZE)
*gtype-basic-offset*
))
)
(else
;; the main thread. We need the main thread's cpu-thread to stick around, so we put it in the
;; process heap.
(let ((alloc (align16 (-> parent-process heap-cur)))) ;; start at heap cur, aligned
;; bump heap to include our thread + its stack
(set! (-> parent-process heap-cur) (the pointer (+ alloc (-> type-to-make size) stack-size)))
(the cpu-thread (+ alloc *gtype-basic-offset*))
)
)
)))
;; set up the type manually, as we allocated the memory manually
(set! (-> obj type) type-to-make)
;; set up thread
(set! (-> obj name) name)
(set! (-> obj process) parent-process)
;; start stack at the top
(set! (-> obj sp) stack-top)
(set! (-> obj stack-top) stack-top)
;; remember the previous thread, in case we're a temp thread
(set! (-> obj previous) (-> parent-process top-thread))
;; and make us the top!
(set! (-> parent-process top-thread) obj)
;; set up our suspend/resume hooks. By default just use the thread's methods.
;; but something else could install a different hook if needed.
(set! (-> obj suspend-hook) (method-of-object obj thread-suspend))
(set! (-> obj resume-hook) (method-of-object obj thread-resume))
;; remember how much space we have for the backup stack.
(set! (-> obj stack-size) stack-size)
obj
)
)
(defmethod asize-of cpu-thread ((obj cpu-thread))
"Get the size of a cpu-thread"
;; we need this because the cpu-thread is stored in the process stack
(the int (+ (-> obj type size) (-> obj stack-size)))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Remove Exit
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun remove-exit ()
"This is likely a defbehavior for process.
Pops a single stack frame, if there is one."
(rlet ((self :reg r13 :type process))
(when (-> self stack-frame-top)
(set! (-> self stack-frame-top) (-> self stack-frame-top next))
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Tree
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GOAL processes are stored in a left child, right sibling tree.
;; The base class of process is process-tree.
;; Each process-tree element has a process-mask which indicates what type of node it is.
(defun-debug stream<-process-mask (stream (mask int))
"Print out a process mask. This function may have been auto-generated?"
; 24
(if (not (eq? 0 (logand mask (process-mask death))))
(format stream "death "))
; 23
(if (not (eq? 0 (logand mask (process-mask attackable))))
(format stream "attackable "))
; 22
(if (not (eq? 0 (logand mask (process-mask projectile))))
(format stream "projectile "))
; 21
(if (not (eq? 0 (logand mask (process-mask entity))))
(format stream "entity "))
; 20
(if (not (eq? 0 (logand mask (process-mask ambient))))
(format stream "ambient "))
; 19
(if (not (eq? 0 (logand mask (process-mask platform))))
(format stream "platform "))
; 18
(if (not (eq? 0 (logand mask (process-mask camera))))
(format stream "camera "))
; 17
(if (not (eq? 0 (logand mask (process-mask enemy))))
(format stream "enemy "))
; 16
(if (not (eq? 0 (logand mask (process-mask collectable))))
(format stream "collectable "))
; 15
(if (not (eq? 0 (logand mask (process-mask crate))))
(format stream "crate "))
; 14
(if (not (eq? 0 (logand mask (process-mask sidekick))))
(format stream "sidekick "))
; 13
(if (not (eq? 0 (logand mask (process-mask target))))
(format stream "target "))
; 12
(if (not (eq? 0 (logand mask (process-mask movie-subject))))
(format stream "movie-subject "))
; 11
(if (not (eq? 0 (logand mask (process-mask movie))))
(format stream "movie "))
; 10
(if (not (eq? 0 (logand mask (process-mask going))))
(format stream "going "))
; 9
(if (not (eq? 0 (logand mask (process-mask heap-shrunk))))
(format stream "heap-shrunk "))
; 8
(if (not (eq? 0 (logand mask (process-mask process-tree))))
(format stream "process-tree "))
; 7
(if (not (eq? 0 (logand mask (process-mask sleep-code))))
(format stream "sleep-code "))
; 6
(if (not (eq? 0 (logand mask (process-mask sleep))))
(format stream "sleep "))
; 5
(if (not (eq? 0 (logand mask (process-mask actor-pause))))
(format stream "actor-pause "))
; 4
(if (not (eq? 0 (logand mask (process-mask progress))))
(format stream "progress "))
; 3
(if (not (eq? 0 (logand mask (process-mask menu))))
(format stream "menu "))
; 2
(if (not (eq? 0 (logand mask (process-mask pause))))
(format stream "pause "))
; 1
(if (not (eq? 0 (logand mask (process-mask draw))))
(format stream "draw "))
; 0
(if (not (eq? 0 (logand mask (process-mask execute))))
(format stream "execute "))
)
;; game state
(define *master-mode* 'game)
(define *pause-lock* #f)
(defmethod new process-tree ((allocation symbol) (type-to-make type) (name basic))
"Create a process-tree node"
;; allocate
(let ((obj (object-new allocation type-to-make)))
(set! (-> obj name) name)
(set! (-> obj mask) (process-mask process-tree))
(set! (-> obj parent) #f)
(set! (-> obj brother) #f)
(set! (-> obj child) #f)
(set! (-> obj self) obj)
(set! (-> obj ppointer) (&-> obj self))
obj
)
)
(defmethod inspect process-tree ((obj process-tree))
"Inspect a process-tree node."
(format #t "[~8x] ~A~%" obj (-> obj type))
(format #t "~Tname: ~S~%" (-> obj name))
(format #t "~Tmask: #x~X~%" (-> obj mask))
(format #t "~Tparent: ~A~%" (as-process (-> obj parent)))
(format #t "~Tbrother: ~A~%" (as-process (-> obj brother)))
(format #t "~Tchild: ~A~%" (as-process (-> obj child)))
obj
)
(defmethod new process ((allocation symbol) (type-to-make type) (name basic) (stack-size int))
"Allocate a new process.
The process stack is initially set to the entire process memory."
(let ((obj (if (eq? (-> allocation type) symbol)
(object-new 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! (-> obj name) name)
(set! (-> obj status) 'dead)
(set! (-> obj pid) 0)
(set! (-> obj pool) #f)
(set! (-> obj allocated-length) stack-size)
(set! (-> obj top-thread) #f)
(set! (-> obj main-thread) #f)
;; set up the heap to start at the stack
(set! (-> obj heap-cur) (-> obj stack))
(set! (-> obj heap-base) (-> obj stack))
;; and end at the end of the stack.
(set! (-> obj heap-top) (&-> (-> obj stack) (-> obj allocated-length)))
;;;;;;;;;;;;;;;;;;;;;;;;;
;; heap top-base bug
;;;;;;;;;;;;;;;;;;;;;;;;;
;; original there was something like (set! (-> heap-top-base) (-> heap-top))
;; but this overlaps with the stack-frame-top and did nothing.
;; this is likely because they added the concept of heap "top" to kheaps in
;; general, but not to process heaps.
;; setup state stuff
(set! (-> obj stack-frame-top) #f)
(set! (-> obj state) #f)
(set! (-> obj next-state) #f)
(set! (-> obj entity) #f)
;; setup handlers
(set! (-> obj trans-hook) #f)
(set! (-> obj post-hook) #f)
(set! (-> obj event-hook) #f)
;; setup process tree
(set! (-> obj parent) #f)
(set! (-> obj brother) #f)
(set! (-> obj child) #f)
;; setup reference stuff.
(set! (-> obj self) obj)
(set! (-> obj ppointer) (&-> obj self))
obj
)
)
(defun inspect-process-heap ((obj process))
"Inspect the heap of a process."
(let ((ptr (&+ (-> obj heap-base) *gtype-basic-offset*))) ; point to first basic
;; loop over objects
(while (< (the int ptr) (the int (-> obj heap-cur)))
;; inspect the object
(inspect (the basic ptr))
;; seek to the next object on the heap.
(set! ptr (&+ ptr (align16 (asize-of (the basic ptr)))))
)
)
)
(defmethod inspect process ((obj process))
(format #t "[~8x] ~A~%" obj (-> obj type))
(format #t "~Tname: ~S~%" (-> obj name))
(format #t "~Tmask: #x~X~%" (-> obj mask))
(format #t "~Tstatus: ~A~%" (-> obj status))
(format #t "~Tmain-thread: ~A~%" (-> obj main-thread))
(format #t "~Ttop-thread: ~A~%" (-> obj top-thread))
(format #t "~Tentity: ~A~%" (-> obj entity))
(format #t "~Tstate: ~A~%" (-> obj state))
(format #t "~Tnext-state: ~A~%" (-> obj next-state))
(format #t "~Ttrans-hook: ~A~%" (-> obj trans-hook))
(format #t "~Tpost-hook: ~A~%" (-> obj post-hook))
(format #t "~Tevent-hook: ~A~%" (-> obj event-hook))
(format #t "~Tparent: ~A~%" (as-process (-> obj parent)))
(format #t "~Tbrother: ~A~%" (as-process (-> obj brother)))
(format #t "~Tchild: ~A~%" (as-process (-> obj child)))
(format #t "~Tconnection-list: ~`connectable`P~%" (-> obj connection-list))
(format #t "~Tstack-frame-top: ~A~%" (-> obj stack-frame-top))
(format #t "~Theap-base: #x~X~%" (-> obj heap-base))
(format #t "~Theap-top: #x~X~%" (-> obj heap-top))
(format #t "~Theap-cur: #x~X~%" (-> obj heap-cur))
;; print all objects on the process heap
(protect (*print-column*)
(+! *print-column* *tab-size*)
(format #t "----~%")
(inspect-process-heap obj)
(format #t "----~%")
)
(format #t "~Tallocated-length: ~D~%" (-> obj allocated-length))
(format #t "~Tstack[~D] @ #x~X~%" (-> obj allocated-length) (-> obj stack))
obj
)
(defmethod asize-of process ((obj process))
(the int (+ (-> process size) (-> obj allocated-length)))
)
(defmethod print process ((obj process))
(format #t "#<~A ~S ~A :state ~S "
(-> obj type)
(-> obj name)
(-> obj status)
(when (-> obj state) (-> obj state name)))
(format #t ":stack ~D/~D :heap ~D/~D @ #x~X>"
(process-stack-used obj)
(process-stack-size obj)
(process-heap-used obj)
(process-heap-size obj)
obj
)
obj
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Context Suspend And Resume - Kernel
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the following functions are used for going from the kernel to 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. (todo - is the stack properly aligned for this?)
(deactivate pp)
;; get the kernel stack pointer as a GOAL pointer
(.load-sym :sext #f sp *kernel-sp*)
;; convert it back to a real pointer
(.add sp off)
;; restore saved registers...
;; without coloring system because this is "cheating".
(.pop :color #f s4)
(.pop :color #f s3)
(.pop :color #f s2)
(.pop :color #f s1)
(.pop :color #f s0)
;; return to the kernel function that called the user code
(.ret)
)
)
(defun reset-and-call ((obj thread) (func function))
"Make the given thread the top thread, reset the stack, and call the function.
Sets up a return trampoline so when the function returns it will return to the
kernel context. 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)
;(print-asm)
)
(rlet ((pp :reg r13 :type process)
(sp :reg rsp :type uint)
(off :reg r15 :type uint)
(s0 :reg rbx :type uint)
(s1 :reg rbp :type uint)
(s2 :reg r10 :type uint)
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint)
(temp :reg rax :type uint)
)
;; set up the process pointer
(set! pp (-> obj process))
;; mark the process as running and set its top thread
(set! (-> pp status) 'running)
(set! (-> pp top-thread) obj)
;; save the current kernel regs
(.push :color #f s0)
(.push :color #f s1)
(.push :color #f s2)
(.push :color #f s3)
(.push :color #f s4)
;; make rsp a GOAL pointer
(.sub sp off)
;; and store it
(set! *kernel-sp* (the pointer sp)) ;; todo, asm form here?
;; setup the rsp for the new thread
(set! sp (the uint (-> obj stack-top)))
(.add sp off)
;; push the return trampoline to the stack for the user code to return to
(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 ((obj :reg r13 :type cpu-thread)
(temp :reg rax :type uint)
(off :reg r15 :type uint)
(sp :reg rsp :type uint)
(s0 :reg rbx :type uint)
(s1 :reg rbp :type uint)
(s2 :reg r10 :type uint)
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint)
(xmm8 :reg xmm8 :class fpr)
(xmm9 :reg xmm9 :class fpr)
(xmm10 :reg xmm10 :class fpr)
(xmm11 :reg xmm11 :class fpr)
(xmm12 :reg xmm12 :class fpr)
(xmm13 :reg xmm13 :class fpr)
(xmm14 :reg xmm14 :class fpr)
(xmm15 :reg xmm15 :class fpr)
)
;; get the return address pushed by "call" in the suspend.
(.pop temp)
;; convert to a GOAL address
(.sub temp off)
;; store return address in thread
(set! (-> obj pc) (the pointer temp))
;; convert our stack pointer to a GOAL address
(.sub sp off)
;; store in thread.
(set! (-> obj sp) (the pointer sp))
;; back up registers
(.mov :color #f temp s0)
(set! (-> obj rreg 0) temp)
(.mov :color #f temp s1)
(set! (-> obj rreg 1) temp)
(.mov :color #f temp s2)
(set! (-> obj rreg 2) temp)
(.mov :color #f temp s3)
(set! (-> obj rreg 3) temp)
(.mov :color #f temp s4)
(set! (-> obj rreg 4) temp)
;; back up fprs
(.mov :color #f temp xmm8)
(set! (-> obj freg 0) (the-as float temp))
(.mov :color #f temp xmm9)
(set! (-> obj freg 1) (the-as float temp))
(.mov :color #f temp xmm10)
(set! (-> obj freg 2) (the-as float temp))
(.mov :color #f temp xmm11)
(set! (-> obj freg 3) (the-as float temp))
(.mov :color #f temp xmm12)
(set! (-> obj freg 4) (the-as float temp))
(.mov :color #f temp xmm13)
(set! (-> obj freg 5) (the-as float temp))
(.mov :color #f temp xmm14)
(set! (-> obj freg 6) (the-as float temp))
(.mov :color #f temp xmm15)
(set! (-> obj freg 7) (the-as float temp))
;; get our process
(let ((proc (-> obj process)))
(when (> (process-stack-used proc) (-> obj stack-size))
(break) ;; too much stack has been used and we can't suspend!
)
;; mark the process as suspended and copy the stack
(set! (-> proc status) 'suspended)
(let ((cur (the (pointer uint64) (-> obj stack-top)))
(save (&+ (the (pointer uint64) (-> obj stack)) (-> obj stack-size)))
)
(while (> (the int cur) (the int sp))
(set! cur (the (pointer uint64) (&- cur 8)))
(set! save (the (pointer uint64) (&- save 8)))
(set! (-> save) (-> cur))
)
)
)
;; actually setting pp to 0
(set! obj (the cpu-thread 0))
;; get the kernel stack pointer as a GOAL pointer
(.load-sym :sext #f sp *kernel-sp*)
;; convert it back to a real pointer
(.add sp off)
;; restore saved registers...
;; without coloring system because this is "cheating".
(.pop :color #f s4)
(.pop :color #f s3)
(.pop :color #f s2)
(.pop :color #f s1)
(.pop :color #f s0)
;; return to the kernel function that called the user code
(.ret)
)
(none)
)
(defmethod thread-resume cpu-thread ((thread-to-resume cpu-thread))
"Resume a suspended thread. Call this from the kernel only.
This is also used to start a thread initialized with set-to-run.
As a result of MIPS/x86 differences, there is a hack for this."
(declare (asm-func none)
;;(print-asm)
)
(rlet ((obj :reg r13 :type cpu-thread)
(temp :reg rax :type uint)
(off :reg r15 :type uint)
(sp :reg rsp :type uint)
(s0 :reg rbx :type uint)
(s1 :reg rbp :type uint)
(s2 :reg r10 :type uint)
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint)
(a4 :reg r8 :type uint)
(a5 :reg r9 :type uint)
(temp-float :reg xmm0 :class fpr)
(xmm8 :reg xmm8 :class fpr)
(xmm9 :reg xmm9 :class fpr)
(xmm10 :reg xmm10 :class fpr)
(xmm11 :reg xmm11 :class fpr)
(xmm12 :reg xmm12 :class fpr)
(xmm13 :reg xmm13 :class fpr)
(xmm14 :reg xmm14 :class fpr)
(xmm15 :reg xmm15 :class fpr)
)
;; save the current kernel regs
(.push :color #f s0)
(.push :color #f s1)
(.push :color #f s2)
(.push :color #f s3)
(.push :color #f s4)
;; make rsp a GOAL pointer
(.sub sp off)
;; and store it
(set! *kernel-sp* (the pointer sp)) ;; todo, asm form here?
;; temp, stash thread in process-pointer
(set! obj thread-to-resume)
;; set stack pointer for the thread. leave it as a GOAL pointer for now..
(set! sp (the uint (-> obj sp)))
;; restore the stack (sp is a GOAL pointer)
(let ((cur (the (pointer uint64) (-> obj stack-top)))
(restore (&+ (the (pointer uint64) (-> obj stack)) (-> obj stack-size)))
)
(while (> (the int cur) (the int sp))
(set! cur (the (pointer uint64) (&- cur 8)))
(set! restore (the (pointer uint64) (&- restore 8)))
(set! (-> cur) (-> restore))
)
)
;; offset sp after we're done using it as a GOAL pointer.
(.add sp off)
;; setup process
(set! (-> (-> obj process) top-thread) obj)
(set! (-> (-> obj process) status) 'running)
;; restore reg
(set! temp (-> obj rreg 0))
(.mov :color #f s0 temp)
(set! temp (-> obj rreg 1))
(.mov :color #f s1 temp)
(set! temp (-> obj rreg 2))
(.mov :color #f s2 temp)
(set! temp (-> obj rreg 3))
(.mov :color #f s3 temp)
(set! temp (-> obj rreg 4))
(.mov :color #f s4 temp)
(set! temp-float (-> obj freg 0))
(.mov :color #f xmm8 temp-float)
(set! temp-float (-> obj freg 1))
(.mov :color #f xmm9 temp-float)
(set! temp-float (-> obj freg 2))
(.mov :color #f xmm10 temp-float)
(set! temp-float (-> obj freg 3))
(.mov :color #f xmm11 temp-float)
(set! temp-float (-> obj freg 4))
(.mov :color #f xmm12 temp-float)
(set! temp-float (-> obj freg 5))
(.mov :color #f xmm13 temp-float)
(set! temp-float (-> obj freg 6))
(.mov :color #f xmm14 temp-float)
(set! temp-float (-> obj freg 7))
(.mov :color #f xmm15 temp-float)
;; hack for set-to-run-bootstrap. The set-to-run-bootstrap in MIPS
;; expects to receive 7 values from the cpu thread's rregs.
;; usually rreg holds saved registers, but on the first resume after
;; a set-to-run, they hold arguments, and set-to-run-bootstrap copies them.
;; We only have 5 saved regs, so we need to cheat and directly pass
;; two values in other registers
;; so we load the a4/a5 argument registers with rreg 5 and rreg 6
;; In the case where we are doing a normal resume, the
;; compiler should assume that these registers are overwritten anyway.
(set! temp (-> obj rreg 5))
(.mov a4 temp)
(set! temp (-> obj rreg 6))
(.mov a5 temp)
;; get the resume address
(set! temp (the uint (-> obj pc)))
(.add temp off)
;; setup the process
(set! obj (the cpu-thread (-> obj process)))
;; resume!
(.jr temp)
)
(none)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Dead Pool
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; a dead-pool is a collection of processes of fixed size that you can get processes from.
(define-extern *debug-dead-pool* dead-pool-heap)
(defmethod new dead-pool ((allocation symbol) (type-to-make type) (count int) (stack-size int) (name basic))
"Create a pool of count dead processes, each with a fixed size stack-size"
(let ((obj (object-new allocation type-to-make)))
;; setup process naming
(set! (-> obj name) name)
(set! (-> obj mask) (process-mask process-tree))
;; setup process tree
(set! (-> obj parent) #f)
(set! (-> obj brother) #f)
(set! (-> obj child) #f)
;; setup ref
(set! (-> obj self) obj)
(set! (-> obj ppointer) (&-> obj self))
(dotimes (i count)
;; create each process
(let ((old-bro (-> obj child))
(next ((method-of-type process new) allocation process 'dead stack-size)))
(set! (-> obj child) (as-ppointer next))
(set! (-> next parent) (as-ppointer obj))
(set! (-> next pool) obj)
(set! (-> next brother) old-bro)
)
)
obj
)
)
(defmethod get-process dead-pool ((obj dead-pool) (type-to-make type) (stack-size int))
"Get a process from this dead pool of the given type."
(let ((proc (-> obj child)))
(when (and (not proc) *debug-segment* (neq? obj *debug-dead-pool*))
;; we failed, but we're in debug mode and not looking at the debug pool
;; try again from the debug pool and warn if this works
(set! proc (the (pointer process-tree) (get-process *debug-dead-pool* type-to-make stack-size)))
(when proc
(format 0 "WARNING: ~A ~A had to be allocated from the debug pool, because ~A was empty.~%"
type-to-make (as-process proc) (-> obj name))
)
;; there's a bug here. proc is a process here, but will be used as a process pointer.
;; let's just kill the program here.
;; this is likely a copy-paste bug from get-process dead-pool-heap.
(break)
)
(cond
(proc
;; success! set our type and return.
(set! (-> (-> proc) type) type-to-make)
(the process (-> proc)) ;; cast from process-tree to process.
)
(else
(format 0 "WARNING: ~A ~A could not be allocated, because ~A was empty.~%"
type-to-make (as-process proc) (-> obj name))
(the process #f)
)
)
)
)
(defmethod return-process dead-pool ((obj dead-pool) (proc process))
"Return a process to its pool once you are done with it."
(change-parent proc obj)
(none)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Dead Pool Heap
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; a dead-pool-heap is a chunk of memory where you can allocate variable sized processes.
;; these processes start out with a lot of memory, then shrink their heap (compact) to the size
;; they actually need. To avoid heap fragmentation, the dead-pool-heap system will relocate
;; processes. This requires that you implement the relocate method on your process.
;; DANGER: the dead pool heap is _not_ a proper process tree. Do not attempt to treat it like on.
;; 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 ((obj (object-new allocation type-to-make (+ (the int (-> type-to-make size))
(align16 (* allocated-length 12))
heap-size))))
(set! (-> obj name) name)
(set! (-> obj mask) (process-mask process-tree))
(set! (-> obj allocated-length) allocated-length)
(set! (-> obj parent) #f)
(set! (-> obj brother) #f)
(set! (-> obj child) #f)
(set! (-> obj self) obj)
(set! (-> obj ppointer) (&-> obj self))
;; initialize each process handle
;; build them into a linked list of null-process
(countdown (i allocated-length)
(let ((rec (-> obj process-list i)))
(set! (-> rec process) *null-process*)
(set! (-> rec next) (-> obj process-list (+ i 1)))
)
)
;; set up the dead-list
(set! (-> obj dead-list next) (-> obj process-list 0))
(set! (-> obj alive-list process) #f) ;; likely typo here, should be dead-list
(set! (-> obj process-list (- allocated-length 1) next) #f)
;; nothing is alive
(set! (-> obj last) (-> obj alive-list))
(set! (-> obj alive-list next) #f)
(set! (-> obj alive-list process) #f)
(set! (-> obj first-gap) (-> obj alive-list))
(set! (-> obj first-shrink) #f)
;; setup the heap. It just begins after the process records.
(set! (-> obj heap base) (the pointer (align16 (-> obj process-list allocated-length))))
(set! (-> obj heap current) (-> obj heap base))
(set! (-> obj heap top) (&+ (-> obj heap base) heap-size))
(set! (-> obj heap top-base) (-> obj heap top))
obj
)
)
(defmethod gap-location dead-pool-heap ((obj dead-pool-heap) (rec dead-pool-heap-rec))
"Get the gap after the given process.
If root of the alive list is given, will give the first gap between the heap and the first process.
If there is no gap, may point to the next process. Not 16-byte aligned."
(cond
((-> rec process)
(the pointer (&+ (-> rec process) (-> process size) (-> rec process allocated-length) (- *gtype-basic-offset*)))
;; start of proc end of type data process's heap basic offset
)
(else
(-> obj heap base)
)
)
)
(defmethod gap-size dead-pool-heap ((obj dead-pool-heap) (rec dead-pool-heap-rec))
"Determine the size between the given process and the next process or end of the heap.
If you give the first rec, it will given the gap between the beginning of the heap and the next process."
(the int
(cond
((-> rec process)
;; compute the end of my process (no basic offset)
(let ((my-end (&+ (-> rec process) (-> process size) (-> rec process allocated-length))))
(if (-> rec next)
;; if there's a next process, look at the difference to the next (basic offsets cancel)
(&- (-> rec next process) my-end)
;; no next process, look at the top of the heap.
(&- (-> obj heap top) (&+ my-end *gtype-basic-offset*))
)
)
)
(else
(if (-> rec next)
(&- (-> rec next process) (&+ (-> obj heap base) *gtype-basic-offset*))
(&- (-> obj heap top) (-> obj heap base)))
)
)
)
)
(defmethod find-gap dead-pool-heap ((obj dead-pool-heap) (rec dead-pool-heap-rec))
"Start at the given record and find the closest gap after it. Returns the rec
which has the gap after it. If no gaps, returns the last rec."
(while (and (-> rec next) (zero? (gap-size obj rec)))
; no gap here!
(set! rec (-> rec next))
)
rec
)
(defmethod inspect dead-pool-heap ((obj dead-pool-heap))
"Inspect a dead-pool-heap and all of the recs and their gaps"
(format #t "[~8x] ~A~%" obj (-> obj type))
(format #t "~Tname: ~A~%" (-> obj name))
(format #t "~Tmask: ~D~%" (-> obj mask))
(format #t "~Tparent: #x~X~%" (-> obj parent))
(format #t "~Tbrother: #x~X~%" (-> obj brother))
(format #t "~Tchild: #x~X~%" (-> obj child))
(format #t "~Tppointer: #x~X~%" (-> obj ppointer))
(format #t "~Tself: ~A~%" (-> obj self))
(format #t "~Tallocated-length: ~D~%" (-> obj allocated-length))
(format #t "~Theap: #<kheap @ #x~X>~%" (-> obj heap))
(format #t "~Tfirst-gap: #<dead-pool-heap-rec @ #x~X>~%" (-> obj first-gap))
(format #t "~Tfirst-shrink: #<dead-pool-heap-rec @ #x~X>~%" (-> obj first-shrink))
(format #t "~Talive-list: #<dead-pool-heap-rec @ #x~X>~%" (-> obj alive-list))
(format #t "~Tlast: #<dead-pool-heap-rec @ #x~X>~%" (-> obj last))
(format #t "~Tdead-list: #<dead-pool-heap-rec @ #x~X>~%" (-> obj dead-list))
;; here we consider the free memory to be all of the stuff after the last process.
;; we don't consider random gaps to be "free".
;; this means you can do a single allocation of free bytes and it will always succeed.
(let* ((total (the int (&- (-> obj heap top) (-> obj heap base))))
(free (if (-> obj last)
(gap-size obj (-> obj last))
total))
)
(format #t "~Tprocess-list[0] @ #x~X ~D/~D bytes used~%" (-> obj process-list) (- total free) total)
)
(let ((rec (-> obj alive-list))
(i 0)
)
(while rec
(when (-> rec process)
(format #t "~T [~3D] #<dead-pool-heap-rec @ #x~X> ~A~%" i rec (-> rec process))
)
(let ((gap (gap-size obj rec)))
(unless (zero? gap)
(format #t "~T gap: ~D bytes @ #x~X~%" gap (gap-location obj rec)))
)
(set! rec (-> rec next))
(+! i 1)
)
)
obj)
(defmethod asize-of dead-pool-heap ((obj dead-pool-heap))
"Get our total size. Uses the heap top as the end."
(- (the int (-> obj heap top)) (the int obj) *gtype-basic-offset*)
)
(defmethod memory-used dead-pool-heap ((obj dead-pool-heap))
"Get the amount of memory used. This includes gaps between processes."
(if (-> obj last)
; we have at least one process, get the not-last-gap memory
(- (memory-total obj) (gap-size obj (-> obj last)))
; no processes.
0
)
)
(defmethod memory-total dead-pool-heap ((obj dead-pool-heap))
"Get the total amount of memory for processes"
(the int (&- (-> obj heap top) (-> obj heap base)))
)
(defmethod memory-free dead-pool-heap ((obj dead-pool-heap))
"Get the total memory free."
(let ((top (-> obj heap top)))
(if (-> obj last)
; get the last gap size
(gap-size obj (-> obj last))
; otherwise just the whole heap.
(the int (&- top (-> obj heap base)))
)
)
)
(defmethod compact-time dead-pool-heap ((obj dead-pool-heap))
"Access the compact time field."
(-> obj compact-time)
)
(defmethod find-gap-by-size dead-pool-heap ((obj dead-pool-heap) (size int))
"Find a gap which will fit at least size bytes. Returns the rec for the proc before the gap.
Will return a #f rec if there's no gap big enough."
; start our search at first-gap
(let ((rec (-> obj first-gap)))
(while (and rec (< (gap-size obj rec) size))
;; nope, not big enough.
(set! rec (-> rec next))
)
rec
)
)
(define-extern *vis-boot* basic)
(defmethod get-process dead-pool-heap ((obj dead-pool-heap) (type-to-make type) (stack-size int))
"Allocate a process"
;; get a record for the new process
(let ((rec (-> obj dead-list next))
;; will eventually hold our new process
(proc (the process #f))
;; find the rec which has a big enough gap
(insert (find-gap-by-size obj (+ (the int (-> process size)) stack-size)))
)
(cond
;; check we got both a record and a gap
((and rec insert)
;; pop the record off of the list
(set! (-> obj dead-list next) (-> rec next))
;; splice it into the alive list in the right spot
(let ((next (-> insert next)))
;; after the gap rec
(set! (-> insert next) rec)
;; us to the process after the gap
(set! (-> rec next) next)
;; link the proc after us back
(when next
(set! (-> next prev) rec)
)
;; and us back to the proc before the gap
(set! (-> rec prev) insert)
;; if we are inserting after the last process, we should update the last.
(when (eq? insert (-> obj last))
(set! (-> obj last) rec)
)
;; get the gap
(set! proc (the process (gap-location obj insert)))
;; and allocate! The method new does the offset for us.
(set! proc ((method-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? (-> obj first-gap) insert)
(set! (-> obj first-gap) (find-gap obj rec))
)
;; we haven't shrunk yet. If we don't have a first-shrink, or we are before it,
;; mark us as first shrink.
(when (or (not (-> obj first-shrink))
(< (the int proc) (the int (-> obj first-shrink process)))
)
(set! (-> obj first-shrink) rec)
)
;; update tree stuff.
(set! (-> proc parent) (-> obj ppointer))
(set! (-> proc pool) obj)
(set! (-> obj child) (&-> rec process))
)
)
(else
;; allocation failed! try again on the debug heap if we're debugging.
(when (and *debug-segment* (not (eq? obj *debug-dead-pool*)))
(set! proc (get-process *debug-dead-pool* type-to-make stack-size))
(when (and proc *vis-boot*)
(format 0 "WARNING: ~A ~A had to be allocated from the debug pool, because ~A was empty.~%" type-to-make proc (-> obj name)))
)
)
)
(cond
(proc
;; success! set type and return.
(set! (-> proc type) type-to-make)
)
(else
;; failure. complain.
(format 0 "WARNING: ~A ~A could not be allocated, because ~A was empty.~%" type-to-make proc (-> obj name))
)
)
proc)
)
(defmethod return-process dead-pool-heap ((obj dead-pool-heap) (proc process))
"Return a process to a dead pool heap"
;; check we are returning to the correct pool
(unless (eq? obj (-> proc pool))
(format 0 "ERROR: process ~A does not belong to dead-pool-heap ~A.~%" proc obj)
)
;; reclaim us.
(change-parent proc obj)
;; we don't maintain a real tree for a dead-pool-heap, so undo any change to child
;; done by change-parent
(set! (-> obj child) #f)
;; we know our ppointer is really a rec for a dead-pool-heap process, so we can use
;; this trick to quickly find our rec.
(let ((rec (the dead-pool-heap-rec (-> proc ppointer))))
;; if we are at or below the first gap, update first gap.
(when (or (eq? (-> obj first-gap) rec)
(< (the int (gap-location obj rec)) (the int (gap-location obj (-> obj first-gap))))
)
(set! (-> obj first-gap) (-> rec prev))
)
;; update the first-shrink. We aren't smart about this and just move it backward.
(when (eq? (-> obj first-shrink) rec)
(set! (-> obj first-shrink) (-> rec prev))
(when (not (-> obj first-shrink process))
(set! (-> obj first-shrink) #f))
)
;; remove us from list
(set! (-> rec prev next) (-> rec next))
(cond
((-> rec next)
;; update links
(set! (-> rec next prev) (-> rec prev))
)
(else
;; we were last, update that.
(set! (-> obj last) (-> rec prev))
)
)
;; insert at the front of the dead list.
(set! (-> rec next) (-> obj dead-list next))
(set! (-> obj dead-list next) rec)
(set! (-> rec process) *null-process*)
(none)
)
)
(defmethod shrink-heap dead-pool-heap ((obj dead-pool-heap) (proc process))
"Shrink the heap of a process.
This resizes the process heap to be the exact size it is currently using."
(when proc
;; get our rec.
(let ((rec (the dead-pool-heap-rec (-> proc ppointer))))
;; check if it's ok to shrink
(unless (or (process-mask? (-> proc mask) heap-shrunk) ;; already shrunk
(and (not (-> proc next-state)) ;; uninitialized
(not (-> proc state))) ;; uninitialized
)
;; shrink!
(set! (-> proc allocated-length) (the int (&- (-> proc heap-cur) (-> proc stack))))
(set! (-> proc heap-top) (&-> (-> proc stack) (-> proc allocated-length)))
;; update first gap
(when (< (the int proc) (the int (gap-location obj (-> obj first-gap))))
(set! (-> obj first-gap) (find-gap obj rec))
)
;; mark us as shrunk
(process-mask-set! (-> proc mask) heap-shrunk)
)
;; update first shrink
(when (eq? (-> obj first-shrink) rec)
(set! (-> obj first-shrink) (-> rec next))
)
)
)
obj
)
(defmethod compact dead-pool-heap ((obj dead-pool-heap) (count int))
"Do heap compaction. The count argument tells us how much work to do.
If the heap is very full we will automatically do more work than requested."
;; first we see how much memory is in use.
(let ((free (memory-free obj))
(total (memory-total obj))
)
(let ((perc (/ (the float free) (the float total))))
(cond
((< perc 0.1)
;; 90% full! set count very large to try to fix this and complain.
(set! count 1000)
(when (and *debug-segment* (-> *kernel-context* low-memory-message))
(format *stdcon* "~3LLow Actor Memory~%~0L")
)
)
((< perc 0.2)
;; 80% full, try 4x harder
(set! count (* count 4))
)
((< perc 0.3)
;; 70% full, try 2x harder
(set! count (* count 2))
)
)
)
)
;; update stats
(set! (-> obj compact-count-targ) count)
(set! (-> obj compact-count) 0)
;; and do compaction!
(countdown (ii count)
;; first try to shrink a heap.
(let ((shrink (-> obj first-shrink)))
(when (not shrink)
;; not sure when this happens, but reset shrink if we need to.
(set! shrink (set! (-> obj first-shrink) (-> obj alive-list next)))
)
(when shrink
;; do a shrink!
(shrink-heap obj (-> shrink process))
)
)
;; now find the first gap
(let ((gap (-> obj first-gap)))
;; and the thing after it
(when (-> gap next)
(let ((proc (-> gap next process))
(size (gap-size obj gap)))
(unless (zero? size)
(format #t "[kernel] Relocating process ~A by ~D.~%" proc (- size))
(when (< size 0)
;; bug!
(break)
)
;; try shrinking before relocating.
(shrink-heap obj proc)
;; relocate!
(relocate proc (- size))
;; update first gap
(set! (-> obj first-gap) (find-gap obj gap))
;; and update stats.
(+! (-> obj compact-count) 1)
)
)
)
)
)
(none)
)
(defmethod churn dead-pool-heap ((obj dead-pool-heap) (count int))
"Mess with the heap"
(countdown (ii count)
(let ((rec (-> obj alive-list next)))
(when rec
(when (or (eq? (-> obj first-gap) rec)
(< (the int (gap-location obj rec)) (the int (gap-location obj (-> obj first-gap))))
)
(set! (-> obj first-gap) (-> rec prev)))
(when (eq? (-> obj first-shrink) rec)
(set! (-> obj first-shrink) (-> rec prev))
(when (not (-> obj first-shrink process))
(set! (-> obj first-shrink) #f))
)
(set! (-> rec prev next) (-> rec next))
(cond
((-> rec next)
(set! (-> rec next prev) (-> rec prev))
)
(else
(set! (-> obj last) (-> rec prev))
)
)
(let* ((insert (-> obj last))
(next (-> insert next))
)
(set! (-> insert next) rec)
(set! (-> rec next) next)
(when next
(set! (-> next prev) rec))
(set! (-> rec prev) insert)
(set! (-> obj last) rec)
(set! (-> rec process) (relocate (-> rec process) (the int (&- (gap-location obj insert)
(the int (&- (-> rec process) *gtype-basic-offset*))))))
)
)
)
)
(none)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Finding
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GOAL lambdas aren't real lambdas, so you have to do this.
(define *global-search-name* (the basic #f))
(define *global-search-count* 0)
(define-extern search-process-tree (function process-tree (function process-tree object) process-tree))
(define-extern iterate-process-tree (function process-tree (function object object) kernel-context object))
(define-extern execute-process-tree (function process-tree (function object object) kernel-context object))
(defun process-by-name (name (pool process-tree))
"Look up a process in the given pool by name"
(set! *global-search-name* (the basic name))
(the process (search-process-tree pool (lambda ((var process))
(name= (-> var name) *global-search-name*))))
)
(defun process-not-name (name (pool process-tree))
"Look up a process with not the given name."
(set! *global-search-name* (the basic name))
(the process (search-process-tree pool (lambda ((var process))
(not (name= (-> var name) *global-search-name*)))))
)
(defun process-count ((this process-tree))
"Count number of processes in the given tree using iterate-process-tree"
(set! *global-search-count* 0)
(iterate-process-tree this
(lambda ((obj process))
(+! *global-search-count* 1)
#t)
*null-kernel-context*)
*global-search-count*)
(defun kill-by-name (name (pool process-tree))
"Call deactivate on all process with the given name."
(let ((proc (the process-tree #f)))
(while (set! proc (process-by-name name pool))
(deactivate proc)
)
)
)
(defun kill-by-type (type (pool process-tree))
"Call deactivate on all processes with the given type"
(set! *global-search-name* (the basic type))
(let ((proc (the process-tree #f)))
(while (set! proc (search-process-tree pool (lambda ((var process))
(= (the type *global-search-name*)
(-> var type)))))
(deactivate proc)
)
)
)
(defun kill-not-name (name (pool process-tree))
"Call deactivate on all processes that don't match the name"
(let ((proc (the process-tree #f)))
(while (set! proc (process-not-name name pool))
(deactivate proc)
)
)
)
(defun kill-not-type (type (pool process-tree))
"Call deactivate on all prcesses that don't match the given type"
(set! *global-search-name* (the basic type))
(let ((proc (the process-tree #f)))
(while (set! proc (search-process-tree pool (lambda ((var process))
(!= (the type *global-search-name*)
(-> var type)))))
(deactivate proc)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Iterating
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod run-logic? process ((obj process))
"Return if the process should be run or not."
#t)
;; the following three functions recursively iterate through process trees.
(defun iterate-process-tree ((obj process-tree) (func (function object object)) (context kernel-context))
"Call func on all processes that aren't a process-tree. If func returns 'dead, stop.
The kernel-context is ignored."
(let ((ret (or (process-mask? (-> obj mask) process-tree)
(func obj))))
(cond
((eq? ret 'dead)
;; stop.
)
(else
;; iterate through brothers
(let ((brother (-> obj child)))
(while brother
;; kinda weird, we use the brother from _before_ recursing.
(let ((old-brother (-> (-> brother) brother)))
(iterate-process-tree (-> brother) func context)
(set! brother old-brother)
)
)
)
)
)
ret
)
)
(defun execute-process-tree ((obj process-tree) (func (function object object)) (context kernel-context))
"Like iterate, but also requires that prevent-from-run's mask doesn't block, and that run-logic?
is true in order to call the function."
;; check mask for tree, mask for prevent, run-logic?, then run!
(let ((ret (or (process-mask? (-> obj mask) process-tree)
(not (and (or (zero? (logand (-> context prevent-from-run) (-> obj mask))))
(run-logic? obj)))
(func obj)
)))
;; run on our children
(cond
((eq? ret 'dead)
)
(else (let ((brother (-> obj child)))
(while brother
(let ((temp (-> (-> brother) brother)))
(execute-process-tree (-> brother) func context)
(set! brother temp))
)
)
)
)
ret)
)
(defun search-process-tree ((obj process-tree) (func (function process-tree object)))
"Find the first process which func return true on. Won't find process-tree's (by mask)"
;; reject process-tree
(unless (process-mask? (-> obj mask) process-tree)
;; is this a match?
(when (func obj)
(return-from #f obj)
)
)
;; not a match, check out children
(let ((brother (-> obj child)))
(while brother
(let ((temp (-> (-> brother) brother)))
(let ((ret (search-process-tree (-> brother) func)))
(when ret
(return-from #f ret)
)
)
(set! brother temp)
)
)
)
(the process-tree #f)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Kernel Dispatcher
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-extern *listener-process* process)
(define-extern *active-pool* process-tree)
(defun kernel-dispatcher ()
"Run the kernel!
"
(when *listener-function*
(let ((result (reset-and-call (-> *listener-process* main-thread) *listener-function*)))
(if *use-old-listener-print*
(format #t "~D~%" result result result)
(format #t "~D #x~X ~F ~A~%" result result result result)
)
)
(set! *listener-function* #f)
(+! *enable-method-set* -1)
)
(execute-process-tree
*active-pool*
(lambda ((obj process))
;(format 0 "Call to dispatcher lambda!~%")
(let ((context *kernel-context*))
(cond
((or (eq? (-> obj status) 'waiting-to-run)
(eq? (-> obj status) 'suspended))
;; we should run!
;; set current process to us
(set! (-> context current-process) obj)
;; update pause junk for this run
(cond
((process-mask? (-> obj mask) pause)
;; we're paused.
(set! *stdcon* *stdcon1*)
(set! *debug-draw-pauseable* #t)
)
(else
(set! *stdcon* *stdcon0*)
(set! *debug-draw-pauseable* #f)
)
)
;; TRANS
(cond
((-> obj trans-hook)
;; we have a trans hook defined. let's create a thread and run it. we can reuse the stack of the main-thread
;; it is safe to do this because the main-thread is currently suspended or hasn't run yet.
(let ((trans (new 'process 'cpu-thread obj 'trans PROCESS_STACK_SAVE_SIZE (-> obj main-thread stack-top))))
;; call the function in the thread.
(reset-and-call trans (-> obj trans-hook))
;; remove the cpu-thread
(delete trans)
;; check for deadness
(when (eq? (-> obj status) 'dead)
(set! (-> context current-process) #f)
(return-from #f 'dead)
)
)
)
)
;; MAIN CODE
(if (process-mask? (-> obj mask) sleep-code)
;; we're sleeping. Move us to suspended, in case we were in waiting to run.
(set! (-> obj status) 'suspended)
;; not sleeping. call resume hook
((-> obj main-thread resume-hook) (-> obj main-thread))
)
;; check for deadness
(cond
((eq? (-> obj status) 'dead)
;; oops we died. return 'dead
(set! (-> context current-process) #f)
'dead
)
(else
;; not dead.
;; POST CODE
(cond
((-> obj post-hook)
(let ((post (new 'process 'cpu-thread obj 'post PROCESS_STACK_SAVE_SIZE *kernel-dram-stack*)))
(reset-and-call post (-> obj post-hook))
(delete post)
(when (eq? (-> obj status) 'dead)
;; oops we died.
(set! (-> context current-process) #f)
(return-from #f 'dead)
)
(set! (-> obj status) 'suspended)
)
)
)
(set! (-> context current-process) #f)
#f
)
)
)
((eq? (-> obj status) 'dead)
'dead)
)
)
)
*kernel-context*
)
)
(define-extern inspect-process-tree (function process-tree int int symbol process-tree))
(defun inspect-process-tree ((obj process-tree) (level int) (mask int) (detail symbol))
"Debug print a pocess-tree"
(print-tree-bitmask mask (+ 0 level))
;; print us
(cond
(detail
(format #t "__________________~%")
;; this is here, but I removed it because it prints at the wrong indent and looks weird.
;(format #t "~S~A~%" (if (zero? level) "" "+---") obj)
(protect (*print-column*)
(set! *print-column* (the binteger (* level 4)))
(inspect obj)
)
)
(else
(format #t "~S~A~%" (if (zero? level) "" "+---") obj)
)
)
;; print our children
(let ((child (-> obj child)))
(while child
(inspect-process-tree (-> child) (+ level 1) (if (not (-> (-> child) brother)) mask (logior mask (ash 1 (+ 1 level)))) detail)
(set! child (-> (-> child) brother))
)
)
obj
)
(defmacro set-u128-as-u64! (dst src)
`(set! (-> (the (pointer uint64) (& ,dst)))
,src
)
)
(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 ((obj (the catch-frame (&+ allocation *gtype-basic-offset*))))
;; setup catch frame
(set! (-> obj type) type-to-make)
(set! (-> obj name) name)
;; get the return address (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 bitys
(.sub temp off)
;; store it
(set! (-> obj ra) (the int temp))
;; todo, do we need a stack offset here?
;; remember the stack pointer
(set! temp sp)
(.sub temp off)
(set! (-> obj sp) (the int temp))
;; back up registers we care about
(.mov :color #f temp s0)
(set-u128-as-u64! (-> obj rreg 0) temp)
(.mov :color #f temp s1)
(set-u128-as-u64! (-> obj rreg 1) temp)
(.mov :color #f temp s2)
(set-u128-as-u64! (-> obj rreg 2) temp)
(.mov :color #f temp s3)
(set-u128-as-u64! (-> obj rreg 3) temp)
(.mov :color #f temp s4)
(set-u128-as-u64! (-> obj rreg 4) temp)
(.mov :color #f temp xmm8)
(set! (-> obj freg 0) (the-as float temp))
(.mov :color #f temp xmm9)
(set! (-> obj freg 1) (the-as float temp))
(.mov :color #f temp xmm10)
(set! (-> obj freg 2) (the-as float temp))
(.mov :color #f temp xmm11)
(set! (-> obj freg 3) (the-as float temp))
(.mov :color #f temp xmm12)
(set! (-> obj freg 4) (the-as float temp))
(.mov :color #f temp xmm13)
(set! (-> obj freg 5) (the-as float temp))
(.mov :color #f temp xmm14)
(set! (-> obj freg 6) (the-as float temp))
(.mov :color #f temp xmm15)
(set! (-> obj freg 7) (the-as float temp))
;; push this stack frame
(set! (-> obj next) (-> pp stack-frame-top))
(set! (-> pp stack-frame-top) obj)
;; help coloring, it isn't smart enough to realize it's "safe" to use these registers.
(.push :color #f s3)
(.push :color #f s2)
(.push :color #f s2)
(set! s3 (the uint func))
(set! s2 param-block)
;; todo - are we aligned correctly here?
(let ((ret ((the-super-u64-fucntion s3)
(-> s2 0)
(-> s2 1)
(-> s2 2)
(-> s2 3)
(-> s2 4)
(-> s2 5)
))
)
(.pop :color #f s2)
(.pop :color #f s2)
(.pop :color #f s3)
(set! (-> pp stack-frame-top) (-> pp stack-frame-top next))
(.ret)
(the object ret)
)
)
)
)
(defun throw-dispatch ((obj catch-frame) value)
"Throw the given value to the catch frame.
Only can throw a 64-bit value. The original could throw 128 bits."
(declare (asm-func none))
(rlet ((pp :reg r13 :type process)
(temp :reg rax :type uint)
(off :reg r15 :type uint)
(sp :reg rsp :type uint)
(s0 :reg rbx :type uint)
(s1 :reg rbp :type uint)
(s2 :reg r10 :type (pointer uint64))
(s3 :reg r11 :type uint)
(s4 :reg r12 :type uint)
(temp-float :reg xmm0 :class fpr)
(xmm8 :reg xmm8 :class fpr)
(xmm9 :reg xmm9 :class fpr)
(xmm10 :reg xmm10 :class fpr)
(xmm11 :reg xmm11 :class fpr)
(xmm12 :reg xmm12 :class fpr)
(xmm13 :reg xmm13 :class fpr)
(xmm14 :reg xmm14 :class fpr)
(xmm15 :reg xmm15 :class fpr)
)
;; pop everything we threw past
(set! (-> pp stack-frame-top) (-> obj next))
;; restore regs we care about.
(set-u64-from-u128! temp (-> obj rreg 0))
(.mov :color #f s0 temp)
(set-u64-from-u128! temp (-> obj rreg 1))
(.mov :color #f s1 temp)
(set-u64-from-u128! temp (-> obj rreg 2))
(.mov :color #f s2 temp)
(set-u64-from-u128! temp (-> obj rreg 3))
(.mov :color #f s3 temp)
(set-u64-from-u128! temp (-> obj rreg 4))
(.mov :color #f s4 temp)
(set! temp-float (-> obj freg 0))
(.mov :color #f xmm8 temp-float)
(set! temp-float (-> obj freg 1))
(.mov :color #f xmm9 temp-float)
(set! temp-float (-> obj freg 2))
(.mov :color #f xmm10 temp-float)
(set! temp-float (-> obj freg 3))
(.mov :color #f xmm11 temp-float)
(set! temp-float (-> obj freg 4))
(.mov :color #f xmm12 temp-float)
(set! temp-float (-> obj freg 5))
(.mov :color #f xmm13 temp-float)
(set! temp-float (-> obj freg 6))
(.mov :color #f xmm14 temp-float)
(set! temp-float (-> obj freg 7))
(.mov :color #f xmm15 temp-float)
;; set stack pointer
(set! sp (the uint (-> obj sp)))
(.add sp off)
;; overwrite our return address
(.pop temp)
(set! temp (the uint (-> obj ra)))
(.add temp off)
(.push temp)
;; load the return register
(.mov temp value)
(.ret)
)
)
(defun throw ((name symbol) value)
"Dynamic throw."
(rlet ((pp :reg r13 :type process))
(let ((cur (-> pp stack-frame-top)))
(while cur
(when (and (eq? (-> cur name) name) (eq? (-> cur type) catch-frame))
;; match!
(throw-dispatch (the catch-frame cur) value)
)
(if (eq? (-> cur type) protect-frame)
;; call the cleanup function
((-> (the protect-frame cur) exit))
)
(set! cur (-> cur next))
)
)
)
(format 0 "ERROR: throw could not find tag ~A~%" name)
(break)
)
(defmethod new protect-frame ((allocation symbol) (type-to-make type) (func (function object)))
(let ((obj (the protect-frame (&+ allocation *gtype-basic-offset*))))
(set! (-> obj type) type-to-make)
(set! (-> obj name) 'protect-frame)
(set! (-> obj exit) func)
(rlet ((pp :reg r13 :type process))
(set! (-> obj next) (-> pp stack-frame-top))
(set! (-> pp stack-frame-top) obj)
)
obj
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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 ((obj process-tree) (new-parent process-tree))
"Make obj a child of new-parent"
(let ((parent (-> obj parent)))
;; parent is a ppointer.
;; need to remove obj from its current parent
(when parent
(let ((proc (-> (-> parent) child)))
(if (eq? (as-process proc) obj)
;; case where we're the first child is easy!
(set! (-> (-> parent) child) (-> obj brother))
;; otherwise, look through brothers to find us.
(begin
(while (not (eq? (as-process (-> (-> proc) brother)) obj))
(set! proc (-> (-> proc) brother))
)
;; ok, got us, splice out of list.
(set! (-> (-> proc) brother) (-> obj brother))
)
)
)
)
;; add to new parent
(set! (-> obj parent) (-> new-parent ppointer))
(set! (-> obj brother) (-> new-parent child))
(set! (-> new-parent child) (-> obj ppointer))
obj
)
)
(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 ((obj 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."
(set! (-> obj mask) (logand (-> dest mask) PROCESS_CLEAR_MASK))
(set! (-> obj status) 'ready)
(let ((pid (-> *kernel-context* next-pid)))
(set! (-> obj pid) pid)
(set! (-> *kernel-context* next-pid) (+ 1 pid)))
(set! (-> obj top-thread) #f)
(set! (-> obj main-thread) #f)
(set! (-> obj name) name)
(set! (-> obj heap-base) (set! (-> obj heap-cur) (&+ (-> obj stack) (-> obj type heap-base))))
(set! (-> obj stack-frame-top) #f)
(mem-set32! (-> obj stack) (the int (/ (-> obj type heap-base) 4)) 0)
(set! (-> obj trans-hook) #f)
(set! (-> obj post-hook) #f)
(set! (-> obj event-hook) #f)
(set! (-> obj state) #f)
(set! (-> obj next-state) #f)
(if (process-mask? (-> dest mask) process-tree)
(set! (-> obj entity) #f)
(set! (-> obj entity) (-> (the process dest) entity))
)
(set! (-> obj connection-list next1) #f)
(set! (-> obj connection-list prev1) #f)
(let ((thread (new 'process 'cpu-thread obj 'code PROCESS_STACK_SAVE_SIZE stack-top)))
(set! (-> obj main-thread) thread)
)
(change-parent obj dest)
)
(defun run-function-in-process ((obj process) (func function) a0 a1 a2 a3 a4 a5)
"Switch to the given process and run the function. This is used to initialize a process.
The function will run until it attempts to change state. At the first attempt to change state,
this function will return. The idea is that you use this when you want to initialize a process NOW.
This will then return the value of the function you called!"
(rlet ((pp :reg r13 :type process))
(let ((param-array (new 'stack 'array 'uint64 6))
)
;; copy params to the stack.
(set! (-> param-array 0) (the uint64 a0))
(set! (-> param-array 1) (the uint64 a1))
(set! (-> param-array 2) (the uint64 a2))
(set! (-> param-array 3) (the uint64 a3))
(set! (-> param-array 4) (the uint64 a4))
(set! (-> param-array 5) (the uint64 a5))
(let* ((old-pp pp)
(func-val (begin
;; set the process
(set! pp obj)
;; set us as initializing
(set! (-> pp status) 'initialize)
;; run!
(the object (new 'stack 'catch-frame 'initialize func param-array))
)))
;; the function returned, either through a throw or through actually returning.
;; the status will give us a clue of what happened.
(cond
((= (-> 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)
)
((= (-> pp status) '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"
(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)
(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)
)
)
(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 ((obj process-tree))
(none)
)
;; The defstate macro isn't defined yet, so we do it manually.
(define dead-state
(new 'static 'state
:name #f
:next #f
:exit #f
:code #f
:trans #f
:post #f
:enter #f
:event #f))
(set! (-> dead-state code) nothing)
;; this is not yet defined.
(define-extern entity-deactivate-handler (function process object none))
(define entity-deactivate-handler (the (function process object none) nothing))
(define-extern process-disconnect (function process int))
(defmethod deactivate process ((obj 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? (-> obj status) 'dead)
(set! (-> obj next-state) dead-state)
;; call entity handler
(when (-> obj entity)
(entity-deactivate-handler obj (-> obj entity))
)
;; clean up stack frames the process is in.
;; first, set pp so the cleanup code thinks its running in the right process.
(rlet ((pp :reg r13 :type process))
(let ((old-pp pp))
(set! pp obj)
(let ((cur (-> pp stack-frame-top)))
(while cur
(when (or
(= (-> cur type) protect-frame)
(= (-> cur type) state)
)
;; we're a state or protect-frame, we can exit.
((-> (the protect-frame cur) exit))
)
(set! cur (-> cur next))
)
)
(set! pp old-pp)
)
)
;; hack - if this isn't defined yet, don't try it.
(if (!= 0 (the uint process-disconnect))
(process-disconnect obj)
)
;; kill our child and their brothers
(let ((bro (-> obj child)))
(while bro
(let ((temp (-> (-> bro) brother)))
(deactivate (-> bro))
(set! bro temp)
)
)
)
;; return ourself to the pool
(return-process (-> obj pool) obj)
(set! (-> obj state) #f)
(set! (-> obj next-state) #f)
(set! (-> obj entity) #f)
(set! (-> obj 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? obj (-> *kernel-context* current-process))
;; go straight to dead.
(set! (-> obj status) 'dead)
;; and return (with no deactivate)
(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? (-> obj status) 'initialize)
;; added this
; (if (!= pp obj)
; (format 0 "ERROR: deactivated a non-current initializing process!")
; (break)
; )
(set! (-> obj status) 'dead)
(throw 'initialize #f)
)
)
(set! (-> obj status) 'dead)
)
(none)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Process Globals
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(let ((obj (define *listener-process* (new 'global 'process 'listener 2048))))
(set! (-> obj status) 'ready)
(set! (-> obj pid) 1)
(set! (-> obj main-thread) (new 'process 'cpu-thread obj 'main 256 *kernel-dram-stack*))
)
;; these are unknown
(define *null-process* (new 'global 'process 'listener 16))
(define *vis-boot* #f)
;; a few pools of fixed size processes that are shared.
(define *16k-dead-pool* (new 'global 'dead-pool 1 (* 16 1024) '*16k-dead-pool*))
(define *8k-dead-pool* (new 'global 'dead-pool 1 (* 8 1024) '*8k-dead-pool*))
(define *4k-dead-pool* (new 'global 'dead-pool 4 (* 4 1024) '*4k-dead-pool*))
;; some very important process pools
(define *target-dead-pool* (new 'global 'dead-pool 1 (* 48 1024) '*target-dead-pool*))
(define *camera-dead-pool* (new 'global 'dead-pool 7 (* 4 1024) '*camera-dead-pool*))
(define *camera-master-dead-pool* (new 'global 'dead-pool 1 (* 8 1024) '*camera-master-dead-pool*))
(if *debug-segment*
(define *debug-dead-pool* (new 'debug 'dead-pool-heap '*debug-dead-pool* 768 (* 1024 1024)))
)
(define *nk-dead-pool* (new 'global 'dead-pool-heap '*nk-dead-pool* 768 PROCESS_HEAP_SIZE))
(define *default-dead-pool* (the dead-pool *nk-dead-pool*))
(define *pickup-dead-pool* (the dead-pool *nk-dead-pool*))
(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
(define *active-pool* (new 'global 'process-tree 'active-pool))
;; other active pools
(change-parent (define *display-pool* (new 'global 'process-tree 'display-pool)) *active-pool*)
(change-parent (define *camera-pool* (new 'global 'process-tree 'camera-pool)) *active-pool*)
(set! (-> *camera-pool* mask) (process-mask pause menu progress camera process-tree))
(change-parent (define *target-pool* (new 'global 'process-tree 'target-pool)) *active-pool*)
(set! (-> *target-pool* mask) (process-mask pause menu progress process-tree))
(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))
(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