jak-project/goal_src/jakx/kernel/gkernel-h.gc

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

;; name: gkernel-h.gc
;; name in dgo: gkernel-h
;; dgos: KERNEL

;; Note: this file has a lot of manual edits.

(defglobalconstant KERNEL_DEBUG #t)

(defconstant *kernel-major-version* 2)
(defconstant *kernel-minor-version* 0)

(defconstant DPROCESS_STACK_SIZE (#if PC_PORT #x10000 #x3800))
(defconstant PROCESS_STACK_SIZE (#if PC_PORT #x8000 #x1c00))

(#if PC_BIG_MEMORY
  (defconstant PROCESS_HEAP_MULT 4) ;; 4x actors
  (defconstant PROCESS_HEAP_MULT 1)
  )
(defconstant PROCESS_HEAP_SIZE (* PROCESS_HEAP_MULT 1240 1024))
(defconstant PROCESS_HEAP_MAX (* PROCESS_HEAP_MULT 768))

(defconstant *tab-size* (the binteger 8))
(defconstant *gtype-basic-offset* 4)

(defconstant *scratch-memory-top* (the pointer #x70004000))

(declare-type process-tree basic)
(declare-type process process-tree)
(declare-type res-lump basic)
(declare-type entity res-lump)
(declare-type entity-actor entity)
(declare-type dead-pool basic)
(declare-type level basic)
(declare-type state basic)
(declare-type event-message-block structure)
(declare-type stack-frame basic)
(declare-type cpu-thread basic)

;; +++gkernel-h:process-mask
(defenum process-mask
  :type uint32
  :bitfield #t
  (execute 0)
  (freeze 1)
  (pause 2)
  (menu 3)
  (progress 4)
  (actor-pause 5)
  (sleep 6)
  (sleep-code 7)
  (process-tree 8)
  (heap-shrunk 9)
  (going 10)
  (kernel-run 11)
  (no-kill 12)
  (movie 13)
  (dark-effect 14)
  (target 15)

  (sidekick 16)
  (crate 17)
  (collectable 18)
  (enemy 19)
  (camera 20)
  (platform 21)
  (ambient 22)
  (entity 23)
  (projectile 24)
  (bot 25)
  (death 26)
  (vehicle 27)
  (network 28)
  )
;; ---gkernel-h:process-mask

;; DECOMP BEGINS

(deftype kernel-context (basic)
  ((prevent-from-run    process-mask)
   (require-for-run     process-mask)
   (allow-to-run        process-mask)
   (next-pid            int32)
   (fast-stack-top      pointer)
   (current-process     process)
   (relocating-process  basic)
   (relocating-min      int32)
   (relocating-max      int32)
   (relocating-offset   int32)
   (relocating-level    level)
   (low-memory-message  symbol)
   (login-object        basic)
   (login-art-group     basic)
   (login-level-index   int32)
   )
  )


(deftype time-frame (int64)
  ()
  )

;; times are stored in 300ths of a second.
;; this divides evenly into frames at both 50 and 60 fps.
;; typically these are stored as integers as more precision is not useful.
;; an unsigned 32-bit integer can store about 150 days
(defglobalconstant TICKS_PER_SECOND 300) ;; 5 t/frame @ 60fps, 6 t/frame @ 50fps

;; this was usec in GOAL
(defmacro seconds (x)
  "Convert number to seconds unit.
   Returns uint."
  (cond
    ((integer? x)
     (* TICKS_PER_SECOND x)
     )
    ((float? x)
     (* 1 (* 1.0 x TICKS_PER_SECOND))
     )
    (#t
     `(the uint (* TICKS_PER_SECOND ,x))
     )
    )
  )

;; Each clock counts in 3 different ways:
;;
;; 1). A "frame counter", which, confusingly, doesn't count frames.
;;     It counts elapsed time, in 1/300ths of a second.
;;     This counts in real-time, even if the game is lagging.
;;
;; 2). A "integral-frame-counter", which counts the number of vsyncs.
;;     This doens't count the number of frames the game actually manages to draw,
;;     just the number of vsyncs. It counts at different rates in NTSC/PAL.
;;     NOTE: changing clock-ratio will make this count faster/slower. This only counts real
;;           vsyncs if clock-ratio is 1.0.
;;
;; 3). The "time ratio", which adjusts based on the actual achieved framerate.
;;     Unlike the others, this isn't a incrementing counter, but instead ratios:
;;      time-adjust-ratio, frames-per-second, seconds-per-frame.
;;
;; For the most part, users should just adjust per-frame values by time-adjust-ratio, and this will
;; compensate for pal/ntsc, lag, and clock-ratio scaling.
;;
;; The clock won't tick if its process-mask is prevent-from-run in the kernel.
;; A clock can change the rate it runs at with clock-ratio.
;; Note: both integral-frame-counter and seconds-per-frame/frames-per-second are affected by
;; clock-ratio, which is somewhat weird.
;; Changing clock-ratio will make integral-frame-counter not count actual vsyncs

(deftype clock (basic)
  ((index                       int16)
   (ref-count                   uint16)
   (mask                        process-mask)
   (clock-ratio                 float)
   (accum                       float)
   (integral-accum              float)
   (frame-counter               time-frame)
   (old-frame-counter           time-frame)
   (integral-frame-counter      time-frame)
   (old-integral-frame-counter  time-frame)
   (sparticle-data              vector  :inline)
   (seconds-per-frame           float)
   (frames-per-second           float)
   (time-adjust-ratio           float)
   )
  (:methods
    (new (symbol type int) _type_)
    (update-rates! (_type_ float) float)
    (advance-by! (_type_ float) clock)
    (tick! (_type_) clock)
    (save! (_type_ (pointer uint64)) int)
    (load! (_type_ (pointer uint64)) int)
    (copy! (_type_ clock) clock)
    (reset! (_type_) none)
    (frame-mask-2 (_type_ int) symbol)
    (frame-mask-4 (_type_ int) symbol)
    (frame-mask-8 (_type_ int) symbol)
    (frame-mask-16 (_type_ int) symbol)
    (frame-mask-32 (_type_ int) symbol)
    (frame-mask-64 (_type_ int) symbol)
    (frame-mask-128 (_type_ int) symbol)
    (frame-mask-256 (_type_ int) symbol)
    )
  )


(defmethod frame-mask-2 ((this clock) (xor-val int))
  "Check if the frame count, xored with `xor-val` has its lowest bit set"
  (not (logtest? (logxor xor-val (-> this integral-frame-counter)) 1))
  )

(defmethod frame-mask-4 ((this clock) (xor-val int))
  "Check if the frame count, xored with `xor-val` has any of its lowest 2 bits set"
  (not (logtest? (logxor xor-val (-> this integral-frame-counter)) 3))
  )

(defmethod frame-mask-8 ((this clock) (xor-val int))
  "Check if the frame count, xored with `xor-val` has any of its lowest 3 bits set"
  (not (logtest? (logxor xor-val (-> this integral-frame-counter)) 7))
  )

(defmethod frame-mask-16 ((this clock) (xor-val int))
  "Check if the frame count, xored with `xor-val` has any of its lowest 4 bits set"
  (not (logtest? (logxor xor-val (-> this integral-frame-counter)) 15))
  )

(defmethod frame-mask-32 ((this clock) (xor-val int))
  "Check if the frame count, xored with `xor-val` has any of its lowest 5 bits set"
  (not (logtest? (logxor xor-val (-> this integral-frame-counter)) 31))
  )

(defmethod frame-mask-64 ((this clock) (xor-val int))
  "Check if the frame count, xored with `xor-val` has any of its lowest 6 bits set"
  (not (logtest? (logxor xor-val (-> this integral-frame-counter)) 63))
  )

(defmethod frame-mask-128 ((this clock) (xor-val int))
  "Check if the frame count, xored with `xor-val` has any of its lowest 7 bits set"
  (not (logtest? (logxor xor-val (-> this integral-frame-counter)) 127))
  )

(defmethod frame-mask-256 ((this clock) (xor-val int))
  "Check if the frame count, xored with `xor-val` has any of its lowest 8 bits set"
  (not (logtest? (logxor xor-val (-> this integral-frame-counter)) 255))
  )

(defmethod new clock ((allocation symbol) (type-to-make type) (index int))
  (let ((gp-0 (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
    (set! (-> gp-0 index) index)
    (set! (-> gp-0 frame-counter) (seconds 1000))
    (set! (-> gp-0 integral-frame-counter) (seconds 1000))
    (set! (-> gp-0 old-frame-counter) (+ (-> gp-0 frame-counter) -1))
    (set! (-> gp-0 old-integral-frame-counter) (+ (-> gp-0 integral-frame-counter) -1))
    (update-rates! gp-0 1.0)
    gp-0
    )
  )

;; The basic node used to organize processes into a tree.
;; The process types themselves are children of the process-tree type
;; Typically, each instance of a game object is a process.
(declare-type view basic)
(deftype process-tree (basic)
  ((name          string                  :offset-assert 4)
   (mask          process-mask            :offset-assert 8)
   (clock         clock                   :offset-assert 12) ;; guessed by decompiler
   (view          view                    :offset-assert 16)
   (parent        (pointer process-tree)  :offset-assert 20) ;; guessed by decompiler
   (brother       (pointer process-tree)  :offset-assert 24) ;; guessed by decompiler
   (child         (pointer process-tree)  :offset-assert 28) ;; guessed by decompiler
   (ppointer      (pointer process)       :offset-assert 32)
   (self          process-tree            :offset-assert 36)
   (profile-ticks uint32                  :offset-assert 40)
   )
  :method-count-assert 15
  :size-assert         #x2c
  :flag-assert         #xf0000002c
  :no-runtime-type
  (:methods
    (new "Allocate a process-tree with the kernel clock." (symbol type string) _type_) ;; 0
    (activate "Move a process from dead to active, moving it to the given tree." (_type_ process-tree string pointer) process-tree) ;; 9
    (deactivate "Make a process dead, clean it up, remove it from the active pool, and return to dead pool." (_type_) none) ;; 10
    (init-from-entity! (_type_ entity-actor) object) ;; 11
    (run-logic? "Should this process be run? Checked by execute-process-tree." (_type_) symbol) ;; 12
    (process-tree-method-13 () none) ;; 13
    (process-tree-method-14 () none)
    )
  )

(deftype thread (basic)
  ((name          symbol)
   (process       process)
   (previous      thread)
   (suspend-hook  (function cpu-thread none))
   (resume-hook   (function cpu-thread none))
   (pc            pointer)
   (sp            pointer)
   (stack-top     pointer)
   (stack-size    int32)
   )
  (:methods
    (stack-size-set! (_type_ int) none)
    (thread-suspend (_type_) none)
    (thread-resume (_type_) none)
    )
  )


(deftype cpu-thread (thread)
  ((rreg   uint64  7)
   (freg   float   8)
   (stack  uint8   :dynamic)
   )
  (:methods
    (new (symbol type process symbol int pointer) _type_)
    )
  )

(deftype process (process-tree)
  ((self             process                                                           :override)
   (pool             dead-pool)
   (status           symbol                                                            :offset-assert 48) ;; guessed by decompiler
   (pid int32)
   (main-thread      cpu-thread                                                        :offset-assert 56) ;; guessed by decompiler
   (top-thread       cpu-thread                                                        :offset-assert 60) ;; guessed by decompiler
   (entity           entity-actor                                                      :offset-assert 64) ;; guessed by decompiler
   (level            level                                                             :offset-assert 68) ;; guessed by decompiler
   (state            state                                                             :offset-assert 72) ;; guessed by decompiler
   (prev-state       state                                                             :offset-assert 76) ;; guessed by decompiler
   (next-state       state                                                             :offset-assert 80) ;; guessed by decompiler
   (state-stack      (array state)                                                     :offset-assert 84) ;; guessed by decompiler
   (trans-hook       function                                                          :offset-assert 88) ;; guessed by decompiler
   (post-hook        function                                                          :offset-assert 92) ;; guessed by decompiler
   (event-hook       (function process int symbol event-message-block object)          :offset-assert 96) ;; guessed by decompiler
   (allocated-length int32                                                             :offset-assert 100)
   (heap-base        pointer                                                           :offset 112) ;; guessed by decompiler
   (heap-top         pointer                                                           :offset-assert 116) ;; guessed by decompiler
   (heap-cur         pointer                                                           :offset-assert 120) ;; guessed by decompiler
   (stack-frame-top  stack-frame                                                       :offset-assert 124) ;; guessed by decompiler
   (connection-list  connectable                                              :inline  :offset-assert 128)
   (stack            uint8                                                    :dynamic :offset-assert 144) ;; guessed by decompiler
   )
  :method-count-assert 15
  :size-assert         #x90
  :flag-assert         #xf00000090
  (:methods
     (new "Allocate a process, set up process heap, self/ppointer, clock." (symbol type string int) _type_) ;; 0
    )
  (:states
    dead-state ;; 10
    )
  )

(deftype dead-pool (process-tree)
  ()
  (:methods
    (new (symbol type int int string) _type_)
    (get-process (_type_ type int object) process)
    (return-process (_type_ process) none)
    )
  )


(deftype dead-pool-heap-rec (structure)
  ((process  process)
   (prev     dead-pool-heap-rec)
   (next     dead-pool-heap-rec)
   )
  :pack-me
  )


(deftype dead-pool-heap (dead-pool)
  ((allocated-length    int32)
   (compact-time        uint32)
   (compact-count-targ  uint32)
   (compact-count       uint32)
   (fill-percent        float)
   (first-gap           dead-pool-heap-rec)
   (first-shrink        dead-pool-heap-rec)
   (heap                kheap               :inline)
   (alive-list          dead-pool-heap-rec  :inline)
   (last                dead-pool-heap-rec  :overlay-at (-> alive-list prev))
   (dead-list           dead-pool-heap-rec  :inline)
   (process-list        dead-pool-heap-rec  :dynamic)
   )
  (:methods
    (new "Allocate and initialize a dead-pool-heap." (symbol type string int int) _type_) ;; 0
    (init "Allocate memory for processes and init records." (_type_ symbol int) none) ;; 16
    (compact "Relocate process in memory to remove gaps, increasing free memory for this dead-pool-heap." (dead-pool-heap int) none) ;; 17
    (shrink-heap "Shrink the heap of a process, allowing the dead pool heap to later reclaim the memory during a compact." (dead-pool-heap process) dead-pool-heap) ;; 18
    (churn "Relocate process in memory, to trigger memory bugs related to process relocation." (dead-pool-heap int) none) ;; 19
    (memory-used "Get the total memory used. Memory in between processes that is not used by a process is considered used." (_type_) int) ;; 20
    (memory-total "Get the total size of the heap for processes." (_type_) int) ;; 21
    (memory-free "Get the size of the unused part of the heap." (dead-pool-heap) int) ;; 22
    (compact-time "Get the compaction time (never set)." (dead-pool-heap) uint) ;; 23
    (gap-size "Get the size of the gap (possibly zero) after the given process. Use #f for the gap at the start of the pool memory." (dead-pool-heap dead-pool-heap-rec) int) ;; 24
    (gap-location "Get pointer to gap (possibly zero size) after the given process" (dead-pool-heap dead-pool-heap-rec) pointer) ;; 25
    (find-gap "Find the first process with a nonzero gap after it, after the given process." (dead-pool-heap dead-pool-heap-rec) dead-pool-heap-rec) ;; 26
    (find-gap-by-size "Find the first gap with a size at least this big" (dead-pool-heap int) dead-pool-heap-rec) ;; 27
    )
  )

(deftype stack-frame (basic)
  ((name symbol)
   (next stack-frame)
   )
  )

(deftype catch-frame (stack-frame)
  ((sp    int32)
   (ra    int32)
   (freg  float    10)
   (rreg  uint128  7)
   )
  (:methods
    (new (symbol type symbol function (pointer uint64)) object)
    )
  )


(deftype protect-frame (stack-frame)
  ((exit  (function object))
   )
  (:methods
    (new (symbol type (function object)) protect-frame)
    )
  )


(deftype handle (uint64)
  ((process (pointer process) :offset   0 :size  32)
   (pid     int32             :offset  32 :size  32)
   (u64     uint64            :offset   0 :size  64)
   )
  )


(deftype handle-wrapper (structure)
  ((handle  uint64)
   )
  )

(defmacro handle->process (handle)
  "Convert a handle to a process. If the process no longer exists, returns #f."
  `(let ((the-handle (the-as handle ,handle)))
     (if (-> the-handle process) ;; if we don't point to a process, kernel sets this to #f
         (let ((proc (-> (-> the-handle process))))
           (if (= (-> the-handle pid) (-> proc pid)) ;; make sure it's the same process
               proc
               )
           )
         )
     )
  )

(defmacro ppointer->process (ppointer)
  "convert a (pointer process) to a process."
  ;; this uses the self field, which seems to always just get set to the object.
  ;; confirmed in Jak 1 that using self here is useless, not sure...
  `(let ((the-pp ,ppointer))
     (if the-pp (-> the-pp 0 self))
     )
  )

(defmacro process->ppointer (proc)
  "safely get a (pointer process) from a process, returning #f if invalid."
  `(let ((the-proc ,proc))
     (if the-proc (-> the-proc ppointer))
     )
  )

(defmacro ppointer->handle (pproc)
  "convert a ppointer to a handle. assumes the ppointer is valid."
  `(let ((the-process (the-as (pointer process) ,pproc)))
      (new 'static 'handle :process the-process :pid (if the-process (-> the-process 0 pid)))
      )
  )

(defmacro process->handle (proc)
  "convert a process to a handle. if proc is #f, returns a #f handle."
  `(ppointer->handle (process->ppointer (the-as process ,proc)))
  )


(defmethod print ((this handle))
  (if (nonzero? this)
      (format #t "#<handle :process ~A :pid ~D>" (handle->process this) (-> this pid))
      (format #t "#<handle :process 0 :pid 0>")
      )
  this
  )

(deftype state (protect-frame)
  ((parent  state)
   (code    function)
   (trans   (function object))
   (post    function)
   (enter   function)
   (event   (function process int symbol event-message-block object))
   )
  (:methods
    (new (symbol type symbol function (function object) function (function object) (function process int symbol event-message-block object)) _type_)
    )
  )


(deftype event-message-block (structure)
  ((to-handle    uint64)
   (to           (pointer process)  :overlay-at to-handle)
   (from-handle  uint64)
   (from         (pointer process)  :overlay-at from-handle)
   (param        uint64             6)
   (message      symbol)
   (num-params   int32)
   )
  )


(deftype event-message-block-array (inline-array-class)
  ((data  event-message-block  :dynamic)
   )
  (:methods
    (send-all! (_type_) none)
    )
  )


(set! (-> event-message-block-array heap-base) (the-as uint 80))

(deftype sql-result (array)
  ((sql-data  object  :dynamic :offset  16)
   )
  (:methods
    (new (symbol type int) _type_)
    )
  )

(defmethod new sql-result ((allocation symbol) (type-to-make type) (num-elts int))
  (let ((v0-0 (object-new allocation type-to-make (the-as int (+ (-> type-to-make size) (* num-elts 4))))))
    (set! (-> v0-0 allocated-length) num-elts)
    (set! (-> v0-0 content-type) (the-as type 'error))
    v0-0
    )
  )

(defmethod print ((this sql-result))
  (format #t "#(~A" (-> this content-type))
  (dotimes (s5-0 (-> this length))
    (format #t " ~A" (-> this sql-data s5-0))
    )
  (format #t ")")
  this
  )

(define *sql-result* (the-as sql-result #f))

(define-extern *collapse-quote* symbol)

(defmacro defbehavior (name process-type bindings &rest body)
  "define a new behavior. This is simply a function where self is bound to the process register,
   which is assumed to have type process-type."
  (if (and
       (> (length body) 1)     ;; more than one thing in function
       (string? (first body))  ;; first thing is a string
       )
      ;; then it's a docstring and we ignore it.
      `(define ,name (lambda :name ,name :behavior ,process-type ,bindings ,@(cdr body)))
      ;; otherwise don't ignore it.
      `(define ,name (lambda :name ,name :behavior ,process-type ,bindings ,@body))
      )
  )

(defmacro process-stack-used (proc)
  "get how much stack the top thread of a process has used."
  `(- (the int (-> ,proc top-thread stack-top))
      (the int (-> ,proc top-thread sp))
      )
  )

(defmacro process-stack-size (proc)
  "get how much stack the top thread of a process has"
  `(-> ,proc top-thread stack-size)
  )

(defmacro process-heap-used (proc)
  "get how much heap a process has used."
  `(- (-> ,proc allocated-length)
      (- (the int (-> ,proc heap-top))
         (the int (-> ,proc heap-cur))
         )
      )
  )

(defmacro process-heap-size (proc)
  "get how much heap a process has"
  `(the int (-> ,proc allocated-length))
  )

(defmacro break ()
  "crash the game by dividing by 0."
  `(/ 0 0)
  )

(defmacro with-pp (&rest body)
  "execute the body with pp bound to the current process register."
  `(rlet ((pp :reg r13 :reset-here #t :type process))
         ,@body)
  )

(defconstant PP (with-pp pp))

(defmacro process-mask? (mask enum-value)
  "Are any of the given bits set in the process mask?"
  `(!= 0 (logand ,mask (process-mask ,enum-value)))
  )

(defmacro process-mask-set! (mask &rest enum-value)
  "Set the given bits in the process mask"
  `(logior! ,mask (process-mask ,@enum-value))
  )

(defmacro process-mask-clear! (mask &rest enum-value)
  "Clear the given bits in the process mask."
  `(logclear! ,mask (process-mask ,@enum-value))
  )

(defmacro suspend ()
  "suspend the current process, to be resumed on the next frame."
  `(rlet ((pp :reg r13 :reset-here #t))
         ;; debug check for stack overflow here, where we can easily print the process name.
         (#when (or KERNEL_DEBUG)
           (rlet ((sp :reg rsp :reset-here #t :type int)
                  (off :reg r15 :type uint))
                 (let* ((sp-goal (- sp off))
                        (stack-top-goal (-> (the process pp) top-thread stack-top))
                        (stack-used (&- stack-top-goal sp-goal))
                        (stack-size (-> (the process pp) top-thread stack-size))
                        )
                   (when (> stack-used stack-size)
                     (format 0 "ERROR: suspend called without enough stack in proc:~%~A~%Stack: ~D/~D~%" pp stack-used stack-size)
                     )
                   )
                 )
           )
         ;; set to the current thread
         (set! pp (-> (the process pp) top-thread))
         ;; call the suspend hook (put nothing as the argument)
         ((-> (the cpu-thread pp) suspend-hook) (the cpu-thread 0))
         ;; the kernel will set pp (possibly to a new value, if we've been relocated) on resume.
         )
  )

(defmacro process-deactivate ()
  "deactivate (kill) the current process"
  `(rlet ((pp :reg r13 :reset-here #t :type process))
         (deactivate pp)
         )
  )

;; Some assembly functions in GOAL are ported to C++, then accessed from GOAL using these mips2c macros.
(defmacro def-mips2c (name type)
  "Define a mips2c object (typically a function)."
  `(begin
     (define-extern ,name ,type)
     (set! ,name (the-as ,type (__pc-get-mips2c ,(symbol->string name))))
     )
  )

(defmacro defmethod-mips2c (name method-id method-type)
  "Define a mips2c method."
  `(method-set! ,method-type ,method-id (__pc-get-mips2c ,name))
  )

(defmacro kheap-alloc (heap size)
  "allocate space for a kheap"
  `(let ((heap ,heap) (size ,size))
    (set! (-> heap base) (malloc 'global size))
    (set! (-> heap current) (-> heap base))
    (set! (-> heap top-base) (&+ (-> heap base) size))
    (set! (-> heap top) (-> heap top-base))
    )
  )

(defmacro kheap-reset (heap)
  "reset the kheap, so you can use its memory again"
  `(let ((heap ,heap))
    (set! (-> heap current) (-> heap base))
    )
  )

(defmacro scratchpad-object (type &key (offset 0))
  "Access an object on the scratchpad."
  `(the-as ,type (&+ *fake-scratchpad-data* ,offset))
  )

(defmacro scratchpad-ptr (type &key (offset 0))
  "Create a pointer to an object on the scratchpad."
  `(the-as (pointer ,type) (&+ *fake-scratchpad-data* ,offset))
  )

(defmacro current-time ()
  `(-> PP clock frame-counter)
  )

(defmacro seconds-per-frame ()
  `(-> PP clock seconds-per-frame)
  )

(defmacro seconds-per-frame-high-fps ()
  "Macro for assuming a 16.6 ms frame time at higher frame rates."
  `(if (= (get-video-mode) 'custom)
     0.016666668
     (-> PP clock seconds-per-frame)
     )
  )

(defmacro set-time! (time)
  `(set! ,time (current-time))
  )

(defmacro time-elapsed? (time duration)
  `(>= (- (current-time) ,time) ,duration)
  )

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