;;-*-Lisp-*-
(in-package goal)
(bundles "KERNEL.CGO")
(require "kernel/gkernel.gc")

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

(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 `(quote ,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 `(quote ,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 call-parent-state-handler (handler &key (type (function none)) &rest args)
  "Call the parent handler for this state."
  `(let ((handler (-> (find-parent-state) ,handler))) (if handler ((the ,type handler) ,@args))))

(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))

;; DECOMP BEGINS

(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
    ;; 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.
         (rlet ((temp)
                (off :reg r15 :type uint :reset-here #t))
           (.mov temp return-from-thread) ;; could probably just call this...
           (.add temp off)
           (.push temp)
           (.ret)
           #f ;; can't get here
           ))))))

(defun send-event-function ((proc process-tree) (msg event-message-block))
  "Function to send an event to a process. Please use the send-event macros when possible"
  (with-pp
    ;; og:preserve-this check that we have a _valid_ process. originally this just checked
    ;; that type != process-tree, but sometimes we might get stale process ref (qbert-plat-master)
    (when (and (valid? proc process #f #f 0)
               (nonzero? (-> (the process proc) pid))
               (-> (the process proc) event-hook))
      (let ((pp-backup pp))
        (set! pp (the process proc))
        (let ((result ((-> (the process proc) event-hook) (-> msg from) (-> msg num-params) (-> msg message) msg)))
          (set! pp pp-backup)
          result)))))

(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) ,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)))

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

(defmacro set-state-time ()
  "set the state-time field of the current object to the current time. process-drawable has one"
  `(set! (-> self state-time) (current-time)))

(defmacro time-passed ()
  "how much time has passed since set-state-time"
  `(- (current-time) (-> self state-time)))

(defmacro time-passed? (time)
  "has it been 'time' since set-state-time?"
  `(>= (time-passed) ,time))

(defmacro suspend-for (time &rest body)
  `(let ((time (current-time))) (until (time-elapsed? time ,time) ,@body (suspend))))
