mirror of
https://github.com/open-goal/jak-project.git
synced 2024-10-20 11:26:18 -04:00
d1ece445d4
Relates to #1353 This adds no new functionality or overhead to the compiler, yet. This is the preliminary work that has: - added code to the compiler in several spots to flag when something is used without being properly required/imported/whatever (disabled by default) - that was used to generate project wide file dependencies (some circulars were manually fixed) - then that graph underwent a transitive reduction and the result was written to all `jak1` source files. The next step will be making this actually produce and use a dependency graph. Some of the reasons why I'm working on this: - eliminates more `game.gp` boilerplate. This includes the `.gd` files to some extent (`*-ag` files and `tpage` files will still need to be handled) this is the point of the new `bundles` form. This should make it even easier to add a new file into the source tree. - a build order that is actually informed from something real and compiler warnings that tell you when you are using something that won't be available at build time. - narrows the search space for doing LSP actions -- like searching for references. Since it would be way too much work to store in the compiler every location where every symbol/function/etc is used, I have to do ad-hoc searches. By having a dependency graph i can significantly reduce that search space. - opens the doors for common shared code with a legitimate pattern. Right now jak 2 shares code from the jak 1 folder. This is basically a hack -- but by having an explicit require syntax, it would be possible to reference arbitrary file paths, such as a `common` folder. Some stats: - Jak 1 has about 2500 edges between files, including transitives - With transitives reduced at the source code level, each file seems to have a modest amount of explicit requirements. Known issues: - Tracking the location for where `defmacro`s and virtual state definitions were defined (and therefore the file) is still problematic. Because those forms are in a macro environment, the reader does not track them. I'm wondering if a workaround could be to search the reader's text_db by not just the `goos::Object` but by the text position. But for the purposes of finishing this work, I just statically analyzed and searched the code with throwaway python code.
546 lines
20 KiB
Common Lisp
546 lines
20 KiB
Common Lisp
;-*-Lisp-*-
|
|
(in-package goal)
|
|
|
|
;; name: gstate.gc
|
|
;; name in dgo: gstate
|
|
;; dgos: KERNEL
|
|
|
|
#|@file
|
|
Summary of state system:
|
|
|
|
A process can be put into a state, using enter-state, or the go macro.
|
|
This will set up the process to run the appropriate handler functions defined by the state.
|
|
The state handlers are:
|
|
- enter : gets run before trans on the first time the state is used. Can be #f. Must return.
|
|
- trans : gets run before code each time the code is run. Can be #f. Must return.
|
|
- code : main thread. Can suspend. If it returns, the process dies
|
|
- exit : gets run when leaving a state. must return.
|
|
- event : not sure of the details here yet.
|
|
|
|
You can use "go" to change the state of a process. This causes the process main thread execution to be abandoned.
|
|
If the main thread has exits/protects on the stack frame, they will be run first to clean up.
|
|
|
|
There are several ways to "go"
|
|
- go during init: when a process is being initialized with run-function-in-process, you can "go".
|
|
this causes the run-function-in-process to return immediately, and the next time the process is dispatched
|
|
it will go into the other state. This will automatically set the process to waiting-to-run,
|
|
and shrink the process heap, if appropriate
|
|
|
|
- go from outside the process. You can temporarily set pp to another process, and have that
|
|
process go to another state. The actual go will occur the next time the process is scheduled.
|
|
Use the go-process macro to do this.
|
|
|
|
- go from a non-main thread in the right process. You can do a go from a temporary thread, like trans or post.
|
|
If you do it from post, the go returns and the rest of the post runs. If you do it from any other thread, the temporary thread
|
|
is immediately abandonded. Like the previous two, it will defer the actual go until the next time the
|
|
process runs.
|
|
|
|
- go from the main thread of the main process. This causes the (-> pp state) to change, the stack frames
|
|
to be cleaned up, and the old state's exit to be called. It will reset the stack, then run the code.
|
|
Unlike the others, this means you "go" immediately.
|
|
|
|
The compiler has two special hooks related to states: go-hook and define-state-hook.
|
|
These take care of doing a go and a state definition and properly checking types.
|
|
|
|
The define-state-hook takes a state object and handlers and defines a global symbol
|
|
with the appropriate state type.
|
|
|
|
The go-hook calls enter state and sets (-> proc next-state) for the given process.
|
|
It type checks the arguments for the entry function.
|
|
|#
|
|
|
|
;; DECOMP BEGINS
|
|
|
|
(defmacro go (next-state &rest args)
|
|
"Change the state of the current process.
|
|
This will only return if this is called within the post thread.
|
|
Otherwise, execution stops here and the kernel will run the next state next time."
|
|
`(with-pp
|
|
(go-hook pp ,next-state ,@args)
|
|
)
|
|
)
|
|
|
|
(defmacro go-virtual (state-name &key (proc self) &rest args)
|
|
"Same as go, but use a virtual state."
|
|
`(go (method-of-object ,proc ,state-name) ,@args)
|
|
)
|
|
|
|
(defmacro go-process (proc next-state &rest args)
|
|
"Make another process go."
|
|
`(with-pp
|
|
(protect (pp)
|
|
(set! pp ,proc)
|
|
(go-hook pp ,next-state ,@args)
|
|
)
|
|
)
|
|
)
|
|
|
|
;; run the given function in a process right now.
|
|
;; will return to here when:
|
|
;; - you return
|
|
;; - you deactivate
|
|
;; - you go
|
|
;; - you throw to 'initialize
|
|
(defmacro run-now-in-process (proc func &rest args)
|
|
"Run a function in another process right now."
|
|
`((the (function _varargs_ object) run-function-in-process)
|
|
,proc ,func ,@args
|
|
)
|
|
)
|
|
|
|
;; sets the main thread of the given process to run the given thing.
|
|
;; this resets the main thread stack back to the top
|
|
(defmacro run-next-time-in-process (proc func &rest args)
|
|
"Set up a process to run a function the next time it is scheduled."
|
|
`((the (function _varargs_ object) set-to-run)
|
|
(-> ,proc main-thread) ,func ,@args
|
|
)
|
|
)
|
|
|
|
(defmacro process-spawn-function (proc-type func &key (from *default-dead-pool*) &key (to *default-pool*) &key (name #f) &key (stack-size #x4000) &key (stack *scratch-memory-top*) &rest args)
|
|
"Start a new process that runs a function on its main thread.
|
|
Returns a pointer to the new process (or #f? on error)."
|
|
|
|
(with-gensyms (new-proc)
|
|
`(let ((,new-proc (the-as ,proc-type (get-process ,from ,proc-type ,stack-size))))
|
|
(when ,new-proc
|
|
((method-of-type ,proc-type activate) ,new-proc ,to ,(if name name `(symbol->string ',proc-type)) ,stack)
|
|
(run-next-time-in-process ,new-proc ,func ,@args)
|
|
(the (pointer ,proc-type) (-> ,new-proc ppointer))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defmacro process-spawn (proc-type &key (init #f) &key (from *default-dead-pool*) &key (to *default-pool*) &key (name #f) &key (stack-size #x4000) &key (stack *scratch-memory-top*) &rest args)
|
|
"Start a new process and run an init function on it.
|
|
Returns a pointer to the new process, or #f (or is it 0?) if something goes wrong."
|
|
|
|
(with-gensyms (new-proc)
|
|
`(let ((,new-proc (the-as ,proc-type (get-process ,from ,proc-type ,stack-size))))
|
|
(when ,new-proc
|
|
((method-of-type ,proc-type activate) ,new-proc ,to ,(if name name `(symbol->string ',proc-type)) ,stack)
|
|
(run-now-in-process ,new-proc ,(if init init (string->symbol (fmt #f "{}-init-by-other" proc-type))) ,@args)
|
|
(the (pointer ,proc-type) (-> ,new-proc ppointer))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;; display a listing of active processes.
|
|
(defmacro ps (&key (detail #f))
|
|
`(inspect-process-tree *active-pool* 0 0 ,detail)
|
|
)
|
|
|
|
;; use a compile-time list to keep track of the type of an anonymous behavior.
|
|
(seval (define *defstate-type-stack* '()))
|
|
(desfun def-state-check-behavior (beh-form beh-type)
|
|
"check if code block is an anonymous behavior. needed for anonymous behaviors on defstate."
|
|
|
|
(when (and (pair? beh-form) (eq? (first beh-form) 'behavior))
|
|
(push! *defstate-type-stack* beh-type)
|
|
)
|
|
)
|
|
(defmacro clear-def-state-stack ()
|
|
(set! *defstate-type-stack* '())
|
|
`(none)
|
|
)
|
|
|
|
;; set when inside a defstate.
|
|
(seval (define *defstate-current-type* #f))
|
|
(seval (define *defstate-current-state-name* #f))
|
|
|
|
;; *no-state* is just used for the compiler to know whether a handler was actually set or not
|
|
(defmacro defstate (state-name parents
|
|
&key (virtual #f)
|
|
&key (event *no-state*)
|
|
&key (enter *no-state*)
|
|
&key (trans *no-state*)
|
|
&key (exit *no-state*)
|
|
&key (code *no-state*)
|
|
&key (post *no-state*)
|
|
&rest body
|
|
)
|
|
"Define a new state!"
|
|
|
|
(with-gensyms (new-state)
|
|
(let ((defstate-type (first parents))
|
|
(docstring ""))
|
|
(when (and (> (length body) 1) (string? (first body)))
|
|
(set! docstring (first body)))
|
|
(when (not (null? *defstate-type-stack*))
|
|
(fmt #t "*defstate-type-stack* leaked! An error probably happened in a previous defstate. stack is: {}"
|
|
*defstate-type-stack*)
|
|
)
|
|
(set! *defstate-type-stack* '())
|
|
(when virtual
|
|
(set! *defstate-current-type* defstate-type)
|
|
(set! *defstate-current-state-name* state-name)
|
|
)
|
|
;; check for default handlers
|
|
(let ((default-handlers (assoc defstate-type *default-state-handlers*)))
|
|
(when default-handlers
|
|
;;(fmt #t "found default-handlers for {}: {}\n" defstate-type default-handlers)
|
|
;; event
|
|
(set! default-handlers (cadr default-handlers))
|
|
(when (and (eq? event '*no-state*) (car default-handlers))
|
|
(set! event (car default-handlers)))
|
|
;; enter
|
|
(set! default-handlers (cdr default-handlers))
|
|
(when (and (eq? enter '*no-state*) (car default-handlers))
|
|
(set! enter (car default-handlers)))
|
|
;; trans
|
|
(set! default-handlers (cdr default-handlers))
|
|
(when (and (eq? trans '*no-state*) (car default-handlers))
|
|
(set! trans (car default-handlers)))
|
|
;; exit
|
|
(set! default-handlers (cdr default-handlers))
|
|
(when (and (eq? exit '*no-state*) (car default-handlers))
|
|
(set! exit (car default-handlers)))
|
|
;; code
|
|
(set! default-handlers (cdr default-handlers))
|
|
(when (and (eq? code '*no-state*) (car default-handlers))
|
|
(set! code (car default-handlers)))
|
|
;; post
|
|
(set! default-handlers (cdr default-handlers))
|
|
(when (and (eq? post '*no-state*) (car default-handlers))
|
|
(set! post (car default-handlers)))
|
|
|
|
(set! default-handlers (cdr default-handlers))
|
|
)
|
|
)
|
|
(def-state-check-behavior event defstate-type)
|
|
(def-state-check-behavior enter defstate-type)
|
|
(def-state-check-behavior trans defstate-type)
|
|
(def-state-check-behavior exit defstate-type)
|
|
(def-state-check-behavior code defstate-type)
|
|
(def-state-check-behavior post defstate-type)
|
|
`(let ((,new-state (new 'static 'state
|
|
:name (quote ,state-name)
|
|
:next #f
|
|
:exit #f
|
|
:code #f
|
|
:trans #f
|
|
:post #f
|
|
:enter #f
|
|
:event #f
|
|
)
|
|
))
|
|
;; the compiler will set the fields of the given state and define the symbol.
|
|
;; This way it can check the individual function types, make sure they make sense, and create
|
|
;; a state with the appropriate type.
|
|
,(if virtual
|
|
`(define-virtual-state-hook ,state-name ,defstate-type ,new-state ,docstring ,(eq? virtual 'override) :event ,event :enter ,enter :trans ,trans :exit ,exit :code ,code :post ,post)
|
|
`(define-state-hook ,state-name ,defstate-type ,new-state ,docstring :event ,event :enter ,enter :trans ,trans :exit ,exit :code ,code :post ,post)
|
|
)
|
|
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defmacro find-parent-state ()
|
|
"Find the first different implementation of the current virtual state above this one."
|
|
(when (or (not *defstate-current-type*)
|
|
(not *defstate-current-state-name*))
|
|
(error "use of find-parent-state outside of a defstate.")
|
|
)
|
|
`(cast-to-method-type
|
|
,*defstate-current-type*
|
|
,*defstate-current-state-name*
|
|
(find-parent-method ,*defstate-current-type* (method-id-of-type ,*defstate-current-type* ,*defstate-current-state-name*))
|
|
)
|
|
)
|
|
|
|
|
|
(defmacro behavior (bindings &rest body)
|
|
"Define an anonymous behavior for a process state. This may only be used inside a defstate!"
|
|
|
|
(let ((behavior-type (first *defstate-type-stack*)))
|
|
(pop! *defstate-type-stack*)
|
|
`(lambda :behavior ,behavior-type ,bindings ,@body)
|
|
)
|
|
)
|
|
|
|
;; set the default handler functions for a process's state handlers
|
|
(seval (define *default-state-handlers* '()))
|
|
(defmacro defstatehandler (proc
|
|
&key (event #f)
|
|
&key (enter #f)
|
|
&key (trans #f)
|
|
&key (exit #f)
|
|
&key (code #f)
|
|
&key (post #f))
|
|
(let ((old (assoc proc *default-state-handlers*))
|
|
(new (list proc (list event enter trans exit code post))))
|
|
(if (not old)
|
|
(append!! *default-state-handlers* new) ;; add new set of default handlers
|
|
(dolist (hnd *default-state-handlers*) ;; replace old handlers with new ones
|
|
(when (eq? (car hnd) old)
|
|
(set-car! hnd new)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
`(none)
|
|
)
|
|
|
|
(defmethod new state
|
|
((allocation symbol)
|
|
(type-to-make type)
|
|
(name symbol)
|
|
(code function)
|
|
(trans (function object))
|
|
(enter function)
|
|
(exit (function object))
|
|
(event (function process int symbol event-message-block object)))
|
|
"Allocate a new state. It seems like this isn't really used much and most states are
|
|
statically allocated and as a result don't have the constructor called."
|
|
(let ((this (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
|
|
(set! (-> this name) name)
|
|
(set! (-> this next) #f)
|
|
(set! (-> this exit) exit)
|
|
(set! (-> this code) code)
|
|
(set! (-> this trans) trans)
|
|
(set! (-> this post) #f)
|
|
(set! (-> this enter) enter)
|
|
(set! (-> this event) event)
|
|
this
|
|
)
|
|
)
|
|
|
|
(defun inherit-state ((child state) (parent state))
|
|
"Copy handler functions from parent to child"
|
|
(cond
|
|
((nonzero? parent)
|
|
(set! (-> child exit) (-> parent exit))
|
|
(set! (-> child code) (-> parent code))
|
|
(set! (-> child trans) (-> parent trans))
|
|
(set! (-> child post) (-> parent post))
|
|
(set! (-> child enter) (-> parent enter))
|
|
(set! (-> child event) (-> parent event))
|
|
)
|
|
(else
|
|
;; Note: this is added to let us defstate on a child before the parent.
|
|
;; The child won't be usable like this, but it will prevent a crash.
|
|
(format 0 "[STATE ERROR] inherit-state got a null parent state. Child is ~A~%" (-> child name))
|
|
)
|
|
)
|
|
|
|
child
|
|
)
|
|
|
|
(defmethod print ((this state))
|
|
"Print a state."
|
|
(format '#t "#<~A ~A @ #x~X>" (-> this type) (-> this name) this)
|
|
this
|
|
)
|
|
|
|
(define-extern enter-state (function object object object object object object object))
|
|
(defun enter-state (arg0 arg1 arg2 arg3 arg4 arg5)
|
|
"Make the process stored in pp enter the state in pp next-state"
|
|
(with-pp
|
|
(if (zero? (-> pp next-state))
|
|
(break!))
|
|
;; unsleep us
|
|
(process-mask-clear! (-> pp mask) sleep sleep-code)
|
|
;; mark as going
|
|
(process-mask-set! (-> pp mask) going)
|
|
(cond
|
|
((= (-> pp status) 'initialize)
|
|
;; did a go during initialize.
|
|
;; remove the old trans hook, if there was one
|
|
(set! (-> pp trans-hook) #f)
|
|
;; set us up to run enter-state again, the next time we're scheduled.
|
|
(set-to-run (-> pp main-thread) enter-state arg0 arg1 arg2 arg3 arg4 arg5)
|
|
;; tell the kernel that we did a go during init
|
|
(set! (-> pp status) 'initialize-go)
|
|
;; abandon this thread, go back to what initialized us!
|
|
(throw 'initialize #t)
|
|
#t
|
|
)
|
|
((!= (-> *kernel-context* current-process) pp)
|
|
;; we aren't actually in process pp right now.
|
|
;; so set us up to go in the next run
|
|
(let ((status-backup (-> pp status)))
|
|
(set! (-> pp trans-hook) #f)
|
|
;; will set waiting-to-run
|
|
(set-to-run (-> pp main-thread) enter-state arg0 arg1 arg2 arg3 arg4 arg5)
|
|
;; restore the old status.
|
|
(set! (-> pp status) status-backup)
|
|
#t
|
|
)
|
|
)
|
|
((= (-> pp main-thread) (-> pp top-thread))
|
|
;; we are in the right process, and in the main thread!
|
|
;; we will do a nonlocal control transfer to the new state's code.
|
|
;; the new state can then suspend and get back to the kernel dispatcher lambda
|
|
;; like normal.
|
|
|
|
;; change state!
|
|
(set! (-> pp state) (-> pp next-state))
|
|
|
|
;; do exits
|
|
(let ((frame (-> pp stack-frame-top)))
|
|
(while frame
|
|
(case (-> frame type)
|
|
((protect-frame state)
|
|
((-> (the-as protect-frame frame) exit))
|
|
)
|
|
)
|
|
(set! frame (-> frame next))
|
|
)
|
|
)
|
|
|
|
;; done with going, clear the mask
|
|
(process-mask-clear! (-> pp mask) going)
|
|
|
|
;; now, update the process:
|
|
(let ((new-state (-> pp state)))
|
|
;; event hook from the current state
|
|
(set! (-> pp event-hook) (-> new-state event))
|
|
;; if we have an exit, push it onto the stack frame
|
|
;; and also blow away the old stack frame
|
|
(if (-> new-state exit)
|
|
(set! (-> pp stack-frame-top) new-state)
|
|
(set! (-> pp stack-frame-top) #f)
|
|
)
|
|
(set! (-> pp post-hook) (-> new-state post))
|
|
(set! (-> pp trans-hook) (-> new-state trans))
|
|
|
|
|
|
;; start up the new state. First run the enter function
|
|
(let ((enter-func (-> new-state enter)))
|
|
(if enter-func
|
|
((the (function _varargs_ none) enter-func) arg0 arg1 arg2 arg3 arg4 arg5)
|
|
)
|
|
)
|
|
|
|
;; run the trans function before the code.
|
|
(let ((trans-func (-> new-state trans)))
|
|
(if trans-func
|
|
(trans-func)
|
|
)
|
|
)
|
|
;; now we run the code, but in a tricky way.
|
|
;; we need to:
|
|
;; - make sure that when this code returns, we do a deactivate
|
|
;; - reset the stack to the top, so we can't just call the code.
|
|
(rlet ((temp)
|
|
(func)
|
|
(sp :reg rsp :type uint)
|
|
(off :reg r15 :type uint)
|
|
(carg0 :reg rdi)
|
|
(carg1 :reg rsi)
|
|
(carg2 :reg rdx)
|
|
(carg3 :reg rcx))
|
|
;; prepare args
|
|
;; compiler will likely have these on the stack, we need to get them in regs
|
|
;; before messing with the stack.
|
|
(.mov carg0 arg0)
|
|
(.mov carg1 arg1)
|
|
(.mov carg2 arg2)
|
|
(.mov carg3 arg3)
|
|
|
|
;; get the main code as an x86-64 pointer
|
|
(.mov func (-> new-state code))
|
|
(.add func off)
|
|
;; reset the stack (scary)
|
|
(.mov sp (-> pp main-thread stack-top))
|
|
(.add sp off)
|
|
;; push the return trampoline for when code returns.
|
|
(.mov temp return-from-thread-dead) ;; will deactivate
|
|
(.add temp off)
|
|
(.push temp)
|
|
;; and call!
|
|
(.jr func)
|
|
;; stupid hack so the compiler doesn't throw away these registers.
|
|
(.add carg0 carg1)
|
|
(.add carg2 carg3)
|
|
#f ;; can't get here
|
|
)
|
|
)
|
|
)
|
|
(else
|
|
;; not in the main-thread.
|
|
;; so we set up the main thread to try again.
|
|
(set! (-> pp trans-hook) #f)
|
|
(set-to-run (-> pp main-thread)
|
|
enter-state arg0 arg1 arg2 arg3 arg4 arg5)
|
|
(when (!= (-> pp top-thread name) 'post)
|
|
;; 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.
|
|
(abandon-thread)
|
|
#f ;; can't get here
|
|
)
|
|
#t
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(kmemopen global "event-queue")
|
|
|
|
(let ((v1-3 (new 'global 'event-message-block-array 64)))
|
|
(set! (-> v1-3 length) 0)
|
|
(define *event-queue* v1-3)
|
|
)
|
|
|
|
(kmemclose)
|
|
|
|
(defun send-event-function ((arg0 process-tree) (arg1 event-message-block))
|
|
"Send an event block to a process."
|
|
(with-pp
|
|
(when (and arg0 (!= (-> arg0 type) process-tree) (-> (the-as process arg0) event-hook) (-> arg1 from))
|
|
(let ((gp-0 pp))
|
|
(set! pp (the-as process arg0))
|
|
(let ((v0-0 ((-> (the-as process arg0) event-hook) (-> arg1 from 0) (-> arg1 num-params) (-> arg1 message) arg1)))
|
|
(set! pp gp-0)
|
|
v0-0
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defmethod send-all! ((this event-message-block-array))
|
|
"Send all pending messages. Will only do the send if both the sender and receiver are still alive."
|
|
(dotimes (s5-0 (-> this length))
|
|
(let* ((a1-0 (-> this data s5-0))
|
|
(a0-2 (handle->process (-> a1-0 to-handle)))
|
|
)
|
|
(if (and a0-2 (handle->process (-> a1-0 form-handle)))
|
|
(send-event-function a0-2 a1-0)
|
|
)
|
|
)
|
|
)
|
|
(set! (-> this length) 0)
|
|
0
|
|
(none)
|
|
)
|
|
|
|
(defun looping-code ()
|
|
"Function which calls suspend in a loop. Can be used to create a thread that does nothing."
|
|
(until #f
|
|
(suspend)
|
|
)
|
|
#f
|
|
)
|
|
|
|
|
|
(defmacro send-event (proc msg &key (from (with-pp pp)) &rest params)
|
|
"Send an event to a process. This should be used over send-event-function"
|
|
`(let ((event-data (new 'stack-no-clear 'event-message-block)))
|
|
(set! (-> event-data from) (process->ppointer ,from))
|
|
(set! (-> event-data num-params) ,(length params))
|
|
(set! (-> event-data message) ,msg)
|
|
,@(apply-i (lambda (x i) `(set! (-> event-data param ,i) (the-as uint ,x))) params)
|
|
(send-event-function ,proc event-data)
|
|
)
|
|
)
|
|
|