jak-project/goal_src/jakx/engine/dma/dma-buffer.gc

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

;; name: dma-buffer.gc
;; name in dgo: dma-buffer
;; dgos: ENGINE, GAME

(defmacro gs-reg-list (&rest reg-ids)
  "Generate a giftag register descriptor list from reg-ids."

  (let ((reg-count (length reg-ids)))
    (when (> (length reg-ids) 16)
      (ferror "too many regs passed to gs-reg-list")
      )
    (let ((list-to-splice '())
          (cur-lst reg-ids)
          (i -1))

        ;; this is questionable.
        (while (and (not (null? cur-lst)) (< i 15))
          (push! list-to-splice (cons 'gif-reg-id (cons (car cur-lst) '())))
          (push! list-to-splice (string->symbol-format ":regs{}" (inc! i)))
          (pop! cur-lst)
          )

        `(new 'static 'gif-tag-regs
            ,@list-to-splice
            )
        )
  #| ;; the opengoal compiler does not have enough constant propagation for this for now
    (let ((i -1))

      `(the-as gif-tag-regs (logior ,@(apply (lambda (x)
          `(shl (the-as uint (gif-reg-id ,x)) ,(* 4 (inc! i)))
                ) reg-ids)
              ))

      )|#
    )
  )

(defmacro dma-buffer-add-base-type (buf pkt dma-type &rest body)
  "Base macro for adding stuff to a dma-buffer. Don't use this directly!"

  (with-gensyms (dma-buf)
    `(let* ((,dma-buf ,buf)
            (,pkt (the-as ,dma-type (-> ,dma-buf base))))

          ,@body

          (set! (-> ,dma-buf base) (&+ (the-as pointer ,pkt) (size-of ,dma-type)))

        )
    )
  )

(defmacro dma-buffer-add-base-data (buf data-type forms)
  "Base macro for adding data words to a dma-buffer.
   Each form in forms is converted into data-type and added to the buffer. NO TYPE CHECKING is performed, so be careful!"

  (with-gensyms (dma-buf ptr)
    `(let* ((,dma-buf ,buf)
            (,ptr (the-as (pointer ,data-type) (-> ,dma-buf base))))

          ,@(apply-i (lambda (x i) `(set! (-> ,ptr ,i) (the-as ,data-type ,x))) forms)

          (set! (-> ,dma-buf base) (&+ (the-as pointer ,ptr) (* ,(length forms) (size-of ,data-type))))

        )
    )
  )


(defmacro dma-buffer-add-cnt-vif2 (buf qwc vif0 vif1)
  "Add a dma-packet to a dma-buffer.
   The packet is made up of a 'cnt' DMAtag (transfer qwc qwords of data after the tag and continue from after that point)
    and includes two vif-tags for vifcode, or something else if needed."

  (with-gensyms (pkt)
    `(dma-buffer-add-base-type ,buf ,pkt dma-packet

        (set! (-> ,pkt dma) (new 'static 'dma-tag :id (dma-tag-id cnt) :qwc ,qwc))

        (set! (-> ,pkt vif0) ,vif0)
        (set! (-> ,pkt vif1) ,vif1)

        )
    )
  )

(defmacro dma-buffer-add-ref-vif2 (buf qwc addr vif0 vif1)
  "Add a dma-packet to a dma-buffer.
   The packet is made up of a 'cnt' DMAtag (transfer qwc qwords of data at addr and continue from after the tag)
    and includes two vif-tags for vifcode, or something else if needed."

  (with-gensyms (pkt)
    `(dma-buffer-add-base-type ,buf ,pkt dma-packet

        (set! (-> ,pkt dma) (new 'static 'dma-tag :id (dma-tag-id ref) :qwc ,qwc :addr (the-as int ,addr)))

        (set! (-> ,pkt vif0) ,vif0)
        (set! (-> ,pkt vif1) ,vif1)

        )
    )
  )

(defmacro dma-buffer-add-ret (buf)
  "Add a dma-packet to a dma-buffer. This packet simply does a DMA 'return' "

  (with-gensyms (pkt)
    `(dma-buffer-add-base-type ,buf ,pkt dma-packet

        (set! (-> ,pkt dma) (new 'static 'dma-tag :id (dma-tag-id ret) :qwc 0))

        (set! (-> ,pkt vif0) (new 'static 'vif-tag :cmd (vif-cmd nop)))
        (set! (-> ,pkt vif1) (new 'static 'vif-tag :cmd (vif-cmd nop)))

        )
    )
  )

(defmacro dma-buffer-add-gif-tag (buf giftag gifregs)
  "Add a giftag to a dma-buffer."

  (with-gensyms (pkt)
    `(dma-buffer-add-base-type ,buf ,pkt gs-gif-tag

        (set! (-> ,pkt tag) ,giftag)

        (set! (-> ,pkt regs) ,gifregs)

        )
    )
  )

(defmacro dma-buffer-add-uint64 (buf &rest body)
  "Add 64-bit words to a dma-buffer. See dma-buffer-add-base-data"

  `(dma-buffer-add-base-data ,buf uint64 ,body)
  )

(defmacro dma-buffer-add-uint128 (buf &rest body)
  "Add 128-bit words to a dma-buffer. See dma-buffer-add-base-data"

  `(dma-buffer-add-base-data ,buf uint128 ,body)
  )

(defmacro dma-buffer-add-gs-set-flusha (buf &rest reg-list)
  "Add a gif cnt dma packet to a dma-buffer for setting GS registers. Up to 16 can be set at once.
   The packet runs the flusha command which waits for GIF transfer to end and VU1 microprogram to stop.
   reg-list is a list of pairs where the car is the register name and the cadr is the value to be set for that register."

  (let ((reg-count (length reg-list))
        (qwc (+ (length reg-list) 1))
        (reg-names (apply first reg-list))
        (reg-datas (apply second reg-list))
        )
    `(begin
      ;; dma tag
      (dma-buffer-add-cnt-vif2 ,buf ,qwc
                              (new 'static 'vif-tag :cmd (vif-cmd flusha))
                              (new 'static 'vif-tag :cmd (vif-cmd direct) :imm ,qwc)
                              )

      ;; gif tag for editing gs regs
      (dma-buffer-add-gif-tag ,buf (new 'static 'gif-tag64 :nloop 1 :eop 1 :nreg ,reg-count)
                                   (gs-reg-list a+d a+d a+d a+d a+d a+d a+d a+d a+d a+d a+d a+d a+d a+d a+d a+d)
                                   )

      ;; gs regs
      (dma-buffer-add-uint64 ,buf
          ,@(apply2 (lambda (x) x) (lambda (x) `(gs-reg64 ,x)) reg-datas reg-names)
          )
      )
    )
  )

(defmacro dma-buffer-add-gs-set (buf &rest reg-list)
  "Add a gif cnt dma packet to a dma-buffer for setting GS registers. Up to 16 can be set at once.
   reg-list is a list of pairs where the car is the register name and the cadr is the value to be set for that register."

  (let ((reg-count (length reg-list))
        (qwc (+ (length reg-list) 1))
        (reg-names (apply first reg-list))
        (reg-datas (apply second reg-list))
        )
    `(begin
      ;; dma tag
      (dma-buffer-add-cnt-vif2 ,buf ,qwc
                              (new 'static 'vif-tag :cmd (vif-cmd nop))
                              (new 'static 'vif-tag :cmd (vif-cmd direct) :imm ,qwc)
                              )

      ;; gif tag for editing gs regs
      (dma-buffer-add-gif-tag ,buf (new 'static 'gif-tag64 :nloop 1 :eop 1 :nreg ,reg-count)
                                   (gs-reg-list a+d a+d a+d a+d a+d a+d a+d a+d a+d a+d a+d a+d a+d a+d a+d a+d)
                                   )

      ;; gs regs
      (dma-buffer-add-uint64 ,buf
          ,@(apply2 (lambda (x) x) (lambda (x) `(gs-reg64 ,x)) reg-datas reg-names)
          )
      )
    )
  )

(defmacro with-cnt-vif-block (bindings &rest body)
  "Start a cnt w/ vif direct to gif dma packet setup for the dma-buffer in bindings.
   With this, you can transfer data through PATH2 without having to setup the tag yourself.
   The qwc of the transfer is determined at runtime at the end of this block."

  (let ((buf (first bindings)))

  (with-gensyms (buf-start buf-qwc)
    `(let ((,buf-start (-> ,buf base)))

        ;; setup the dmatag for PATH2 transfer, qwc is 0 (patched later)
        (dma-buffer-add-cnt-vif2 ,buf 0
                        (new 'static 'vif-tag :cmd (vif-cmd nop))
                        (new 'static 'vif-tag :cmd (vif-cmd direct))
                        )

        ;; things with this buffer!
        ,@body

        ;; patch qwc! just do the difference between the current ptr and the old one and turn it into qwords.
        ;; we take one qword out because it's the initial dmatag which isnt part of the count.
        ;; this rounds *down*, so make sure to fill the buffer in 128-bit boundaries.
        (let ((,buf-qwc (/ (+ (&- -16 ,buf-start) (the int (-> ,buf base))) 16)))
          (cond
            ((nonzero? ,buf-qwc) ;; stuff was added to the buffer
             ;; patch the DMA tag
             (logior! (-> (the-as (pointer dma-tag) ,buf-start) 0) (the-as uint (new 'static 'dma-tag :qwc ,buf-qwc)))
             ;; patch the 2nd vifcode's imm field (qwc)
             (logior! (-> (the-as (pointer dma-tag) ,buf-start) 1) (the-as uint (shl (shr (shl ,buf-qwc 48) 48) 32)))
             )
            (else ;; nothing was added to the buffer. delete the dmatag, you cannot transfer 0 qwords.
             (set! (-> ,buf base) ,buf-start)
             )
            )
          )
        )

    ))
  )

(defmacro with-cnt-vif-block-qwc (bindings &rest body)
  "Start a cnt w/ vif direct to gif dma packet setup for the dma-buffer in bindings.
   With this, you can transfer data through PATH2 without having to setup the tag yourself.
   The qwc of the transfer is determined at runtime at the end of this block.
   WARNING: You MUST guarantee that the resulting qwc is NOT zero!"

  (let ((buf (first bindings)))

  (with-gensyms (buf-start buf-qwc)
    `(let ((,buf-start (the-as dma-packet (-> ,buf base))))
        ;; dmatag will be added at the end so we reserve
        (&+! (-> ,buf base) 16)

        ;; setup the dmatag for PATH2 transfer, qwc is 0 (patched later)
        (dma-buffer-add-cnt-vif2 ,buf 0
                        (new 'static 'vif-tag :cmd (vif-cmd nop))
                        (new 'static 'vif-tag :cmd (vif-cmd direct))
                        )

        ;; things with this buffer!
        ,@body

        ;; we make the dmatag now! its at the start.
        (let ((,buf-qwc (/ (+ (- -16 (the-as int ,buf-start)) (the-as int (-> ,buf base))) 16)))
          (set! (-> ,buf-start dma) (new 'static 'dma-tag :id (dma-tag-id cnt) :qwc ,buf-qwc))
          (set! (-> ,buf-start vif0) (new 'static 'vif-tag))
          (set! (-> ,buf-start vif1) (new 'static 'vif-tag :cmd (vif-cmd direct) :msk #x1 :imm ,buf-qwc))
          )
        )

    ))
  )

(defmacro with-dma-bucket (bindings &rest body)
  "Start a new dma-bucket in body that will be finished at the end.
  The bindings are the dma-buffer, dma-bucket and bucket-id respectively."

  (let ((buf (first bindings))
        (bucket (second bindings))
        (bucket-id (third bindings))
        )

    (with-gensyms (buf-start bucket-edge pkt)
      `(let ((,buf-start (-> ,buf base)))

         ,@body

         ;; we end the chain with a next.  The bucket system will patch the next chain to this,
         ;; and then patch all the buckets togehter before sending the DMA.
         (let ((,bucket-edge (the (pointer dma-tag) (-> ,buf base))))

           ;; if nothing was added, skip the tag entirely.
           ;;(when (!= ,bucket-edge ,buf-start)
             (let ((,pkt (the-as dma-packet (-> ,buf base))))

               (set! (-> ,pkt dma) (new 'static 'dma-tag :id (dma-tag-id next)))
               (set! (-> ,pkt vif0) (new 'static 'vif-tag :cmd (vif-cmd nop)))
               (set! (-> ,pkt vif1) (new 'static 'vif-tag :cmd (vif-cmd nop)))

               (set! (-> ,buf base) (&+ (the-as pointer ,pkt) (size-of dma-packet)))

               )
             (dma-bucket-insert-tag ,bucket ,bucket-id
                                    ,buf-start ;; the first thing in this chain, bucket will patch previous to this
                                    ,bucket-edge ;; end of this chain (ptr to next tag)
                                    )
             ;; )
           )
         )
      )
    )
  )

(defmacro with-dma-buffer-add-bucket (bindings &key (bucket-group (-> (current-frame) bucket-group)) &rest body)
  "Bind a dma-buffer to a variable and use it on a block to allow adding things to a new bucket.
   usage: (with-dma-buffer-add-bucket ((buffer-name buffer) bucket-id) &rest body)
   example: (with-dma-buffer-add-bucket ((buf (-> (current-frame) debug-buf)) (bucket-id debug-no-zbuf)) ...)"

  `(let ((,(caar bindings) ,(cadar bindings)))
    (with-dma-bucket (,(caar bindings) ,bucket-group ,(cadr bindings))
      ,@body
      )
    )
  )

;; DECOMP BEGINS

(deftype dma-packet (structure)
  "The header for a DMA transfer, containing an DMA tag, and VIF tags."
  ((dma   dma-tag)
   (vif0  vif-tag)
   (vif1  vif-tag)
   (quad  uint128  :overlay-at dma)
   )
  )


(deftype dma-packet-array (inline-array-class)
  "Unused dma array. Unclear how it should be used."
  ((data  dma-packet  :dynamic)
   )
  )


(set! (-> dma-packet-array heap-base) (the-as uint 16))

(deftype dma-gif (structure)
  "Believed unused GIF header type."
  ((gif   uint64   2)
   (gif0  uint64   :overlay-at (-> gif 0))
   (gif1  uint64   :overlay-at (-> gif 1))
   (quad  uint128  :overlay-at (-> gif 0))
   )
  )


(deftype dma-gif-packet (structure)
  "The header for a DMA transfer that goes directly to GIF, containing DMA, VIF, GIF tags."
  ((dma-vif  dma-packet  :inline)
   (gif      uint64      2)
   (gif0     uint64        :overlay-at (-> gif 0))
   (gif1     uint64        :overlay-at (-> gif 1))
   (quad     uint128     2 :overlay-at (-> dma-vif dma))
   )
  )


(deftype dma-buffer (basic)
  "A buffer for DMA data."
  ((allocated-length  int32)
   (base              pointer)
   (end               pointer)
   (real-buffer-end   int32)
   (data-buffer       uint8   :dynamic :overlay-at real-buffer-end)
   (data              uint64  1        :offset  32)
   )
  (:methods
    (new (symbol type int) _type_)
    )
  )


(defmethod new dma-buffer ((allocation symbol) (type-to-make type) (size-bytes int))
  "Allocate a DMA buffer to hold the given size"
  (let ((v0-0 (object-new allocation type-to-make (+ size-bytes -4 (-> type-to-make size)))))
    (set! (-> v0-0 base) (-> v0-0 data))
    (set! (-> v0-0 allocated-length) size-bytes)
    (set! (-> v0-0 real-buffer-end) (the-as int (&+ (-> v0-0 data) size-bytes)))
    v0-0
    )
  )

(defun dma-buffer-inplace-new ((dma-buff dma-buffer) (size-bytes int))
  (set! (-> dma-buff base) (-> dma-buff data))
  (set! (-> dma-buff allocated-length) size-bytes)
  dma-buff
  )

(defmethod length ((this dma-buffer))
  (-> this allocated-length)
  )

(defmethod asize-of ((this dma-buffer))
  (+ (-> this allocated-length) -4 (-> dma-buffer size))
  )

(defun dma-buffer-length ((dma-buf dma-buffer))
  (shr (+ (&- (-> dma-buf base) (the-as uint (-> dma-buf data))) 15) 4)
  )

(defun dma-buffer-free ((dma-buf dma-buffer))
  (shr (+ (&- (-> dma-buf end) (the-as uint (-> dma-buf base))) 15) 4)
  )

;; ERROR: Failed store: (s.w! (+ t2-0 8) t3-5) at op 23
;; ERROR: Failed store: (s.w! (+ t2-0 12) t3-8) at op 32
(defun dma-buffer-add-vu-function ((dma-buf dma-buffer) (vu-func vu-function) (flush-path-3 int))
  "Add DMA tags to load the given VU function. The destination in vu instruction memory
   is specific inside the vu-function. This does NOT copy the vu-function into the buffer,
   but creates a reference to the existing VU function."
  ;; The first 4 bytes of a vu-function object's data are discarded because they aren't aligned.
  (let ((func-ptr (the-as pointer (&-> vu-func data 4)))
        ;; og:preserve-this we rely on the vu functions being empty on pc
        (qlen (#if PC_PORT 0 (-> vu-func qlength))) ;; number of quadwords
        (origin (-> vu-func origin)) ;; destination address in VU instruction memory.
        )
    ;; loop until whole program is transferred.
    (while (> qlen 0)
      ;; transfer up to 127 quadwords at a single time.
      (let ((qwc-now (min 127 qlen)))
        ;; Set up DMA to transfer the data from the vu-function
        ;; ref id = reference to data outside of the buffer.
        (dma-buffer-add-ref-vif2 dma-buf qwc-now func-ptr
                    ;; Set up first vifcode as a flush.
                    (new 'static 'vif-tag :cmd (if (zero? flush-path-3) (vif-cmd flushe) (vif-cmd flusha)))
                    ;; next vifcode, transfer microprogram. This is in 64-bit units (VU instructions)
                    (new 'static 'vif-tag :cmd (vif-cmd mpg) :num (shl qwc-now 1) :imm origin)
                    )
        ;; increment by qwc-now quadwords.
        (&+! func-ptr (shl qwc-now 4))
        (set! qlen (- qlen qwc-now))
        (+! origin (shl qwc-now 1))
        )
      )
    )
  #f
  )

(defun dma-buffer-send ((chan dma-bank) (buf dma-buffer))
  "Send the DMA buffer! DOES NOT TRANSFER TAG, you probably want dma-buffer-send-chain instead."
  (when (< (-> buf allocated-length) (&- (-> buf base) (the-as uint (-> buf data))))
    (crash!)
    0
    )
  (dma-send chan (the-as uint (-> buf data)) (the-as uint (dma-buffer-length buf)))
  (none)
  )

(defun dma-buffer-send-chain ((chan dma-bank-source) (buf dma-buffer))
  "Send the DMA buffer! Sends the tags, so this is suitable for the main graphics chain."
  (when (< (-> buf allocated-length) (&- (-> buf base) (the-as uint (-> buf data))))
    (crash!)
    0
    )
  (dma-send-chain chan (the-as uint (-> buf data)))
  (none)
  )