jak-project/goal_src/kernel/gstate.gc

;;-*-Lisp-*-
(in-package goal)

;; name: gstate.gc
;; name in dgo: gstate
;; dgos: KERNEL

#|
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. 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.

|#

;; cause the current process to change state
(defmacro go (next-state &rest args)
  `(with-pp
     (set! (-> pp next-state) ,next-state)
     ((the (function _varargs_ object) enter-state) ,@args)
     )
  )

;; cause the given process to change state.
(defmacro go-process (proc state &rest args)
  `(with-pp
     (protect (pp)
              (set! pp ,proc)
              (set! (-> pp next-state) ,state)
              ((the (function _varargs_ object) enter-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)
  `((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)
  `((the (function _varargs_ object) set-to-run)
    (-> ,proc main-thread) ,func ,@args
    )
  )

;; display a listing of active processes.
(defmacro ps (&key (detail #f))
  `(inspect-process-tree *active-pool* 0 0 ,detail)
  )


;; define a state state
(defmacro defstate (state-name
                    &key (event #f)
                    &key (enter #f)
                    &key (trans #f)
                    &key (exit #f)
                    &key (code #f)
                    &key (post #f)
                      )
  `(begin
    (define ,state-name (new 'static 'state
                             :name (quote ,state-name)
                             :next #f
                             :exit #f
                             :code #f
                             :trans #f
                             :post #f
                             :enter #f
                             :event #f
                             )
      )
    ,(if event
         `(set! (-> ,state-name event) ,event)
         `(none)
         )
    ,(if enter
         `(set! (-> ,state-name enter) (the (function object object object object object object object) ,enter))
         `(none)
         )
    ,(if trans
         `(set! (-> ,state-name trans) ,trans)
         `(none)
         )
    ,(if exit
         `(set! (-> ,state-name exit) ,exit)
         `(none)
         )
    ,(if code
         `(set! (-> ,state-name code) ,code)
         `(none)
         )
    ,(if post
         `(set! (-> ,state-name post) ,post)
         `(none)
         )
    )
    
  )
  

(defmethod new state
  ((allocation symbol)
   (type-to-make type)
   (name basic)
   (code function)
   (trans (function object))
   (enter (function object object object object object object object))
   (exit (function object))
   (event (function basic int basic 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 ((obj (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
    (set! (-> obj name) name)
    (set! (-> obj next) '#f)
    (set! (-> obj exit) exit)
    (set! (-> obj code) code)
    (set! (-> obj trans) trans)
    (set! (-> obj post) '#f)
    (set! (-> obj enter) enter)
    (set! (-> obj event) event)
    obj
    )
  )

(defun inherit-state ((child state) (parent state))
  "Copy handler functions from parent to child"
  (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))
  child
  )

(defmethod print state ((obj state))
  "Print a state."
  (format '#t "#<~A ~A @ #x~X>" (-> obj type) (-> obj name) obj)
  obj
  )

(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"
  ;;(declare (print-asm))
  (with-pp
    ;; 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-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!
       ;; actually do a go!
       (set! (-> pp state) (-> pp next-state))

       ;; loop through current stack frames
       (let ((frame (-> pp stack-frame-top)))
         (while frame
           (let ((typ (-> frame type)))
             (if (or (= typ protect-frame) (= typ state))
                 ;; if we got a protect-frame or a state, call exit handler
                 ((-> (the protect-frame frame) exit))
                 )
             )
           (set! frame (-> frame next))
           )
         )
       
       ;; done with going!
       (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))
         ;; now do the enter
         (let ((enter-func (-> new-state enter)))
           (if enter-func
               (enter-func arg0 arg1 arg2 arg3 arg4 arg5)
               )
           )
         ;; now do the trans
         (let ((trans-func (-> new-state trans)))
           (if trans-func
               (trans-func)
               )
           )
         ;; now we run the code, but in a tricky way.
         (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)
           (.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.
         (rlet ((temp)
                (off :reg r15 :type uint :reset-here #t))
           (.mov temp return-from-thread)
           (.add temp off)
           (.push temp)
           (.ret)
           #f ;; can't get here
           )
         )
       )
      )
    )
  )

(defun send-event-function ((proc process) (msg event-message-block))
  (with-pp
    (when (and proc (!= (-> proc type) process-tree) (-> proc event-hook))
      (let ((pp-backup pp))
        (set! pp proc)
        (let ((result ((-> proc event-hook) (-> msg from) (-> msg num-params) (-> msg message) msg)))
          (set! pp pp-backup)
          result
          )
        )
      )
    )
  )

(defun looping-code ()
  "Loop."
  (while #t
    (suspend)
    )
  #f
  )