jak-project/goal_src/jak1/kernel/gcommon.gc

;;-*-Lisp-*-
(in-package goal)
(bundles "KERNEL.CGO")
(require "compiler-setup.gc")
(require "kernel-defs.gc")

;; gcommon is the first file compiled and loaded.
;; it implements some features of built-in types
;; and language constants

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Game constants
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; disable PS2 only code and enable PC-specific code
(defglobalconstant PC_PORT #t)

;; whether we're allowed to use more memory than the original game or not
(defglobalconstant BIG_MEMORY #t)

(defglobalconstant PC_BIG_MEMORY (and PC_PORT BIG_MEMORY))

;; redirects access to EE memory mapped registers through get-vm-ptr to valid addresses that
;; are monitored in the runtime for debugging.
(defglobalconstant USE_VM #f)

;; enables the with-profiler statements, which send profiling data from
;; GOAL code to the frame profiler in C++.
(defglobalconstant PC_PROFILER_ENABLE #t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; GOAL language constants
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; distance from a symbol pointer to a (pointer string)
;; this relies on the memory layout of the symbol table
;; this must match SYM_INFO_OFFSET in goal_constants.h + offset of the str field in struct SymUpper.
(defconstant SYM_TO_STRING_OFFSET #x20000) ;; changed from #xff38

;; pointers larger than this are invalid by valid?
(defconstant END_OF_MEMORY #x8000000)

;; GOAL boxed offsets use the lower three bits to indicate if they are
;; an integer (binteger), a pair, or a strucutre with type info (basic)
(defconstant BINTEGER_OFFSET 0)

(defconstant PAIR_OFFSET 2)

(defconstant BASIC_OFFSET 4)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro symbol->string (sym)
  "Convert a symbol to a goal string."
  `(-> (the-as (pointer string) (+ SYM_TO_STRING_OFFSET (the-as int ,sym)))))

(defmacro get-vm-ptr (ptr)
  "Turn an EE register address into a valid PS2 VM address"
  `(#cond
    (USE_VM (vm-ptr ,ptr))
    (#t ,ptr)))

;; DECOMP BEGINS

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Function versions of built-in forms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; basic operations like +, - are handled by the compiler.
;; these provide actual functions that wrap these common operations.
;; this allows you to use them as actual function objects

(defun identity ((value object))
  "Return value unchanged. This is the first function loaded by the game. The upper 64 bits of a 128-bit value are not preserved."
  value)

(defun 1/ ((x float))
  "Return the reciprocal of x."
  (declare (inline))
  (/ 1. x))

(defun + ((x int) (y int))
  "Add two integers."
  (+ x y))

(defun - ((x int) (y int))
  "Subtract the second integer from the first."
  (- x y))

(defun * ((x int) (y int))
  "Multiply two integers."
  (* x y))

(defun / ((x int) (y int))
  "Divide the first integer by the second."
  (/ x y))

(defun ash ((value int) (shift-amount int))
  "Arithmetically shift value left for a positive shift-amount and right for a negative shift-amount."
  (declare (inline))
  (#unless PC_PORT
    (return (ash value shift-amount)))
  ;; The PC compiler has separate left- and right-shift operations.
  (if (> shift-amount 0) (shl value shift-amount) (sar value (- shift-amount))))

(defun mod ((x int) (y int))
  "Return the signed 32-bit division remainder. Negative operands follow the machine's signed-division behavior."
  (mod x y))

(defun rem ((x int) (y int))
  "Return the signed 32-bit division remainder; this is identical to mod."
  (mod x y))

(defun abs ((value int))
  "Return the absolute value of an integer."
  (declare (inline))
  (#unless PC_PORT
    (return (abs value)))
  (if (> value 0) value (- value)))

(defun min ((x int) (y int))
  "Return the smaller integer."
  (declare (inline))
  (#unless PC_PORT
    (return (min x y)))
  (if (> x y) y x))

(defun max ((x int) (y int))
  "Return the larger integer."
  (declare (inline))
  (#unless PC_PORT
    (return (max x y)))
  (if (> x y) x y))

(defun logior ((x int) (y int))
  "Compute the bitwise inclusive-or."
  (logior x y))

(defun logand ((x int) (y int))
  "Compute the bitwise and."
  (logand x y))

(defun lognor ((x int) (y int))
  "Compute the bitwise complement of the inclusive-or."
  (declare (inline))
  (#unless PC_PORT
    (return (lognor x y)))
  ;; The EE has a single NOR instruction; the PC implementation composes OR and NOT.
  (lognot (logior x y)))

(defun logxor ((x int) (y int))
  "Compute the bitwise exclusive-or."
  (logxor x y))

(defun lognot ((value int))
  "Compute the bitwise complement."
  (lognot value))

(defun false-func ()
  "Return false."
  '#f)

(defun true-func ()
  "Return true."
  '#t)

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; format
;;;;;;;;;;;;;;;;;;;;;;;;;;

;; The C Kernel implements the format function and creates a trampoline function in the GOAL heap which jumps to
;; format.  (In OpenGOAL, there's actually two trampoline functions, to make the 8 arguments all work.)
;; For some reason, the C Kernel names this trampoline function _format. We need to set the value of format
;; _format in order for format to work.

;; I suspect this was to let us define (yet another) function here which set up C-style var args (supported from C Kernel)
;; or 128-bit arguments (unimplemented in C Kernel), but both of these were never finished.
(define format _format)

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; numeric types
;;;;;;;;;;;;;;;;;;;;;;;;;;

;; vec4s packs 4 floats into a single 128-bit integer register.
;; This is not used very often.
(deftype vec4s (uint128)
  ((x float :offset 0)
   (y float :offset 32)
   (z float :offset 64)
   (w float :offset 96)))

(defmethod inspect ((this vec4s))
  (format #t "[~8x] ~A~%" this 'vec4s)
  (format #t "~Tx: ~f~%" (-> this x))
  (format #t "~Ty: ~f~%" (-> this y))
  (format #t "~Tz: ~f~%" (-> this z))
  (format #t "~Tw: ~f~%" (-> this w))
  this)

(defmethod print ((this vec4s))
  (format #t "#<vector ~F ~F ~F ~F @ #x~X>" (-> this x) (-> this y) (-> this z) (-> this w) this)
  this)

(defmacro print128 (value &key (stream #t))
  "Print a 128-bit value"
  `(let ((temp (new 'stack-no-clear 'array 'uint64 2)))
    (set! (-> (the (pointer uint128) temp)) ,value)
    (format ,stream "#x~16X~16X" (-> temp 1) (-> temp 0))))

(defmacro make-u128 (upper lower)
  "Make a i128 from two 64-bit values."
  `(rlet ((result :class i128)
         (upper-xmm :class i128)
         (lower-xmm :class i128))
    (.mov upper-xmm ,upper)
    (.mov lower-xmm ,lower)
    (.pcpyld result upper-xmm lower-xmm)
    (the-as uint result)))

;; A "boxed float" type. Simply a float with type information.
(deftype bfloat (basic)
  ((data float)))

(defmethod print ((this bfloat))
  (format #t "~f" (-> this data))
  this)

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Type System
;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmethod asize-of ((this type))
  "Get the size in memory of a type"
  ;; The 28 is 8 bytes too large. It's also strange that types have a 16-byte aligned size always,
  ;; but this matches what the runtime does as well. There's no reason that I can see for this,
  ;; as other basics don't require 16-byte aligned sizes.
  ;; - maybe the 16-byte aligned size was a requirement if types were stored in the symbol table?
  ;; - maybe types used to be a little bit larger, they made an effort to pack fields tightly.
  (logand #xfffffff0 (+ 15 (* 4 (-> this allocated-length)) 28)))

(defun basic-type? ((this basic) (parent-type type))
  "Return true when this basic object derives from parent-type. This requires a fully defined type and intentionally returns false for object."
  (let ((obj-type (-> this type))
        (end-type object))
    (until (= obj-type end-type)
      (if (= obj-type parent-type) (return #t))
      (set! obj-type (-> obj-type parent))))
  #f)

(defun type-type? ((child-type type) (parent-type type))
  "Return true when child-type is parent-type or derives from it. Incomplete types safely return false."
  (let ((end-type object))
    (until (or (= child-type end-type) (zero? child-type))
      (if (= child-type parent-type) (return #t))
      (set! child-type (-> child-type parent))))
  #f)

(defun find-parent-method ((child-type type) (method-id int))
  "Walk the parent chain until method-id has a different implementation than child-type. Only call this for a known method slot: there are no method-table bounds checks."
  (local-vars (current-method function))
  (let ((original-method (-> child-type method-table method-id)))
    (until (!= current-method original-method)
      (if (= child-type object) (return nothing))
      (set! child-type (-> child-type parent))
      (set! current-method (-> child-type method-table method-id))
      (if (zero? current-method) (return nothing))))
  current-method)

(defmacro call-parent-method (&rest args)
  "Find the first different implementation of the current method in a parent type and call it with these arguments."
  `((the (current-method-function-type) (find-parent-method (current-method-type) (current-method-id))) ,@args))

(defmacro as-type (this type)
  "Macro to _safely_ convert to a different type, returning #f if the type doesn't match.
   Does a runtime type check so it's expensive."
  `(if (and (nonzero? ,this) (type-type? (-> ,this type) ,type)) (the-as ,type ,this)))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pairs, lists, etc
;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun ref ((list object) (index int))
  "Return the list element at index."
  (dotimes (count index)
    (nop!)
    (nop!)
    (set! list (cdr list)))
  (car list))

(defmethod length ((this pair))
  "Get the length of a proper list"
  (local-vars (result int))
  (cond
    ((null? this) (set! result 0))
    (else
     (let ((iter (cdr this)))
       (set! result 1)
       (while (and (not (null? iter)) (pair? iter))
         (+! result 1)
         (set! iter (cdr iter))))))
  result)

(defmethod asize-of ((this pair))
  "Get the size in memory of pair."
  (the-as int (-> pair size)))

(defun last ((list object))
  "Return the last pair in a proper list."
  (let ((iter list)) (while (not (null? (cdr iter))) (nop!) (nop!) (set! iter (cdr iter))) iter))

(defun member ((item object) (list object))
  "Return the list tail whose car is item, or false when item is absent."
  (let ((iter list))
    (while (not (or (null? iter) (= (car iter) item)))
      (set! iter (cdr iter)))
    (if (not (null? iter)) iter)))

;; need to forward declare this, we haven't loaded the string library yet.
(define-extern name= (function basic basic symbol))

(defun nmember ((item basic) (list object))
  "Return the list tail whose first item has the same name."
  (while (not (or (null? list) (name= (the-as basic (car list)) item)))
    (set! list (cdr list)))
  (if (not (null? list)) list))

(defun assoc ((key object) (alist object))
  "Return the key-value pair for key in an association list, or false when absent."
  (let ((iter alist))
    (while (not (or (null? iter) (= (car (car iter)) key)))
      (set! iter (cdr iter)))
    (if (not (null? iter)) (car iter))))

(defun assoce ((key object) (alist object))
  "Return the key-value pair for key in an association list. An else key acts as a fallback."
  (let ((iter alist))
    (while (not (or (null? iter) (= (car (car iter)) key) (= (car (car iter)) 'else)))
      (set! iter (cdr iter)))
    (if (not (null? iter)) (car iter))))

(defun nassoc ((item-name string) (alist object))
  "Return the named key-value pair from an association list. A key may be a single named object or a list of aliases."
  (while (not (or (null? alist)
                  (let ((key (car (car alist)))) (if (pair? key) (nmember item-name key) (name= (the-as basic key) item-name)))))
    (set! alist (cdr alist)))
  (if (not (null? alist)) (car alist)))

(defun nassoce ((item-name string) (alist object))
  "Return the named key-value pair from an association list. Keys may be alias lists, and a single else key acts as a fallback."
  (while (not (or (null? alist)
                  (let ((key (car (car alist))))
                    (if (pair? key) (nmember item-name key) (or (name= (the-as basic key) item-name) (= key 'else))))))
    (set! alist (cdr alist)))
  (if (not (null? alist)) (car alist)))

(defun append! ((front object) (back object))
  "Destructively attach back to the final pair of front and return the combined list. If front is empty, return back directly."
  (cond
    ((null? front)
     ;; can't append to '(), just return back.
     back)
    (else
     (let ((iter front))
       (while (not (null? (cdr iter)))
         (nop!)
         (nop!)
         (set! iter (cdr iter)))
       (if (not (null? iter)) (set! (cdr iter) back)))
     front)))

(defun delete! ((item object) (list object))
  "Remove the first list element equal to item and return the possibly changed list head."
  (the-as pair
          (cond
            ((= item (car list)) (cdr list))
            (else
             (let ((iter-prev list)
                   (iter (cdr list)))
               (while (not (or (null? iter) (= (car iter) item)))
                 (set! iter-prev iter)
                 (set! iter (cdr iter)))
               (if (not (null? iter)) (set! (cdr iter-prev) (cdr iter))))
             list))))

(defun delete-car! ((item object) (list object))
  "Remove the first list element whose car is item."
  (cond
    ((= item (car (car list))) (cdr list))
    (else
     (let ((iter-prev list)
           (iter (cdr list)))
       (while (not (or (null? iter) (= (car (car iter)) item)))
         (set! iter-prev iter)
         (set! iter (cdr iter)))
       (if (not (null? iter)) (set! (cdr iter-prev) (cdr iter))))
     list)))

(defun insert-cons! ((entry object) (alist object))
  "Insert a key-value pair into an association list, replacing an existing entry. This allocates one pair on the global heap."
  (let ((updated-list (delete-car! (car entry) alist))) (cons entry updated-list)))

(defun sort ((list pair) (compare-func (function object object object)))
  "Destructively bubble-sort a list by swapping adjacent out-of-order cars until a pass makes no swaps. An integer comparator returns a positive value when the first item should follow the second, so (sort list -) is ascending. A boolean comparator must return exactly #t for an in-order pair; another truthy value can be mistaken for a positive integer."
  ;; the compare function can return a few possible things.
  ;; we assume "unsorted" if compare-result is #f explicitly, or if it positive.
  ;; HOWEVER, #t itself is positive. So if we get #t, we assume sorted.
  ;; there is possibly an ambiguity, if you happen to return a positive integer that
  ;; happens to be a pointer to #t,
  (let ((unsorted-count -1))
    ;; loop, until unsorted count goes to 0.
    (while (nonzero? unsorted-count)
      ;; search for unsorted things...
      (set! unsorted-count 0)
      (let ((iter list))
        (while (not (or (null? (cdr iter)) (not (pair? (cdr iter)))))
          (let* ((first-elt (car iter))
                 (second-elt (car (cdr iter)))
                 (compare-result (compare-func first-elt second-elt)))
            ;; the compare function can return a few possible things.
            ;; we assume "unsorted" if compare-result is #f explicitly, or if it positive.
            ;; HOWEVER, '#t itself is positive. So if we get #t, we assume sorted.
            ;; there is possibly an ambiguity, if you happen to return a positive integer that
            ;; happens to be a pointer to #t,
            (when (and (or (not compare-result) (> (the-as int compare-result) 0)) (!= compare-result #t))
              (+! unsorted-count 1)
              (set! (car iter) second-elt)
              (set! (car (cdr iter)) first-elt)))
          (set! iter (cdr iter))))))
  list)

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; inline-array-class
;;;;;;;;;;;;;;;;;;;;;;;;;;

;; This is used as base class for boxed inline arrays.
;; The heap-base of the _type_ object will be used to store the stride
;; This way, you don't pay the price of storing the stride in each object.
;; however, as far as we've seen, nothing actually reads the stride.

(deftype inline-array-class (basic)
  ((length           int32)
   (allocated-length int32)
   ;; this is 16-byte aligned.
   ;; children of inline-array-class should define their own data which overlays this one.
   (_data            uint8 :dynamic :offset 16))
  (:methods
   (new (symbol type int) _type_)))

(defmethod new inline-array-class ((allocation symbol) (type-to-make type) (count int))
  "Allocate an inline array with count elements."
  (let ((this (object-new allocation
                          type-to-make
                          (the-as int (+ (-> type-to-make size) (* (the-as uint count) (-> type-to-make heap-base)))))))
    (when (nonzero? this)
      (set! (-> this length) count)
      (set! (-> this allocated-length) count))
    this))

(defmethod length ((this inline-array-class))
  "Return the active element count, not the allocated capacity."
  (-> this length))

(defmethod asize-of ((this inline-array-class))
  "Return the header size plus the allocated capacity at this array type's element stride."
  (the-as int (+ (-> this type size) (the-as uint (* (-> this allocated-length) (the-as int (-> this type heap-base)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; array
;;;;;;;;;;;;;;;;;;;;;;;;;;

;; the GOAL array type is a boxed array.
;; it is a basic that knows its content type, currently used length, and allocated length.
;; It can hold:
;;   any boxed object (gets 4 bytes, so bintegers get clipped to 32-bits)
;;   any structure/reference/pointer
;;   any integer/float
;; It cannot hold any inlined structures.

(defmethod new array ((allocation symbol) (type-to-make type) (content-type type) (count int))
  "Allocate a new array to hold count elements of type content-type.
   The content should either be a numeric type (child of number)
   or the content should be a reference (will get 4-bytes for a pointer)"
  (let ((this (object-new allocation
                          type-to-make
                          (the-as int
                                  (+ (-> type-to-make size) (* count (if (type-type? content-type number) (the-as int (-> content-type size)) 4)))))))
    (set! (-> this allocated-length) count)
    (set! (-> this length) count)
    (set! (-> this content-type) content-type)
    this))

(defmethod print ((this array))
  (format #t "#(")
  (cond
    ((type-type? (-> this content-type) integer)
     (case (-> this content-type symbol)
       (('int32) (dotimes (i (-> this length)) (format #t (if (zero? i) "~D" " ~D") (-> (the-as (array int32) this) i))))
       (('uint32) (dotimes (i (-> this length)) (format #t (if (zero? i) "~D" " ~D") (-> (the-as (array uint32) this) i))))
       (('int64) (dotimes (i (-> this length)) (format #t (if (zero? i) "~D" " ~D") (-> (the-as (array int64) this) i))))
       (('uint64) (dotimes (i (-> this length)) (format #t (if (zero? i) "#x~X" " #x~X") (-> (the-as (array uint64) this) i))))
       (('int8) (dotimes (i (-> this length)) (format #t (if (zero? i) "~D" " ~D") (-> (the-as (array int8) this) i))))
       (('uint8) (dotimes (i (-> this length)) (format #t (if (zero? i) "~D" " ~D") (-> (the-as (array uint8) this) i))))
       (('int16) (dotimes (i (-> this length)) (format #t (if (zero? i) "~D" " ~D") (-> (the-as (array int16) this) i))))
       (('uint16) (dotimes (i (-> this length)) (format #t (if (zero? i) "~D" " ~D") (-> (the-as (array uint16) this) i))))
       (('uint128 'int128)
        (dotimes (i (-> this length))
          (format #t (if (zero? i) "#x~X" " #x~X") (-> (the-as (array uint128) this) i))))
       (else (dotimes (i (-> this length)) (format #t (if (zero? i) "~D" " ~D") (-> (the-as (array int32) this) i))))))
    ((= (-> this content-type) float)
     (dotimes (i (-> this length))
       (if (zero? i) (format #t "~f" (-> (the-as (array float) this) i)) (format #t " ~f" (-> (the-as (array float) this) i)))))
    (else
     (dotimes (i (-> this length))
       (if (zero? i) (format #t "~A" (-> (the-as (array basic) this) i)) (format #t " ~A" (-> (the-as (array basic) this) i))))))
  (format #t ")")
  this)

(defmethod inspect ((this array))
  (format #t "[~8x] ~A~%" this (-> this type))
  (format #t "~Tallocated-length: ~D~%" (-> this allocated-length))
  (format #t "~Tlength: ~D~%" (-> this length))
  (format #t "~Tcontent-type: ~A~%" (-> this content-type))
  (format #t "~Tdata[~D]: @ #x~X~%" (-> this allocated-length) (-> this data))
  (cond
    ((type-type? (-> this content-type) integer)
     (case (-> this content-type symbol)
       (('int32) (dotimes (i (-> this length)) (format #t "~T  [~D] ~D~%" i (-> (the-as (array int32) this) i))))
       (('uint32) (dotimes (i (-> this length)) (format #t "~T  [~D] ~D~%" i (-> (the-as (array uint32) this) i))))
       (('int64) (dotimes (i (-> this length)) (format #t "~T  [~D] ~D~%" i (-> (the-as (array int64) this) i))))
       (('uint64) (dotimes (i (-> this length)) (format #t "~T  [~D] #x~X~%" i (-> (the-as (array uint64) this) i))))
       (('int8) (dotimes (i (-> this length)) (format #t "~T  [~D] ~D~%" i (-> (the-as (array int8) this) i))))
       (('uint8) (dotimes (i (-> this length)) (format #t "~T  [~D] ~D~%" i (-> (the-as (array int8) this) i))))
       (('int16) (dotimes (i (-> this length)) (format #t "~T  [~D] ~D~%" i (-> (the-as (array int16) this) i))))
       (('uint16) (dotimes (i (-> this length)) (format #t "~T  [~D] ~D~%" i (-> (the-as (array uint16) this) i))))
       (('int128 'uint128) (dotimes (i (-> this length)) (format #t "~T  [~D] #x~X~%" i (-> (the-as (array uint128) this) i))))
       (else (dotimes (i (-> this length)) (format #t "~T  [~D] ~D~%" i (-> (the-as (array int32) this) i))))))
    ((= (-> this content-type) float)
     (dotimes (i (-> this length))
       (format #t "~T  [~D] ~f~%" i (-> (the-as (array float) this) i))))
    (else (dotimes (i (-> this length)) (format #t "~T  [~D] ~A~%" i (-> (the-as (array basic) this) i)))))
  this)

(defmethod length ((this array))
  "Get the length of an array"
  (-> this length))

(defmethod asize-of ((this array))
  "Get the size in memory of an array"
  (the-as int
          (+ (-> array size)
             (* (-> this allocated-length) (if (type-type? (-> this content-type) number) (-> this content-type size) 4)))))

;;;;;;;;;;;;;;;;;;;;;;;;
;; memory manipulation
;;;;;;;;;;;;;;;;;;;;;;;;

(defun mem-copy! ((dst pointer) (src pointer) (byte-count int))
  "Copy byte-count bytes in ascending address order."
  (let ((result dst))
    (dotimes (i byte-count)
      (set! (-> (the-as (pointer uint8) dst)) (-> (the-as (pointer uint8) src)))
      (&+! dst 1)
      (&+! src 1))
    result))

(defun qmem-copy<-! ((dst pointer) (src pointer) (byte-count int))
  "Copy in ascending address order using quadwords. Source and destination must be 16-byte aligned; byte-count is rounded up to 16 bytes."
  (let ((result dst))
    (countdown (qwc (/ (+ byte-count 15) 16))
      (set! (-> (the-as (pointer uint128) dst)) (-> (the-as (pointer uint128) src)))
      (&+! dst 16)
      (&+! src 16))
    result))

(defun qmem-copy->! ((dst pointer) (src pointer) (byte-count int))
  "Copy in descending address order using quadwords. Source and destination must be 16-byte aligned; byte-count is rounded up to 16 bytes."
  (let ((result dst))
    (let* ((qwc (/ (+ byte-count 15) 16))
           (dst-ptr (&+ dst (* qwc 16)))
           (src-ptr (&+ src (* qwc 16))))
      (while (nonzero? qwc)
        (+! qwc -1)
        (&+! dst-ptr -16)
        (&+! src-ptr -16)
        (set! (-> (the-as (pointer uint128) dst-ptr)) (-> (the-as (pointer uint128) src-ptr)))))
    result))

(defun mem-set32! ((dst pointer) (word-count int) (value int))
  "Fill word-count 32-bit words with value. The count precedes the fill value."
  (let ((result dst)) (dotimes (i word-count) (set! (-> (the-as (pointer int32) dst)) value) (&+! dst 4) (nop!)) result))

(defun mem-or! ((dst pointer) (src pointer) (byte-count int))
  "Bitwise-or byte-count bytes from src into dst."
  (let ((result dst))
    (dotimes (i byte-count)
      (logior! (-> (the-as (pointer uint8) dst)) (-> (the-as (pointer uint8) src)))
      (&+! dst 1)
      (&+! src 1))
    result))

(defun quad-copy! ((dst pointer) (src pointer) (qwc int))
  "Copy qwc aligned quadwords from src to dst."
  ;; Four quadwords are copied per loop so the EE can overlap loads and stores. Each tail branch
  ;; speculatively loads the next quadword in its delay slot, including the branch taken for qwc=0.
  (#unless PC_PORT
    (rlet ((dst-cursor)
           (src-cursor)
           (remaining qwc)
           (tail-count)
           (quad0 :class i128)
           (quad1 :class i128)
           (quad2 :class i128)
           (quad3 :class i128))
      (nop!)
      (set! tail-count (- remaining 4))
      (set! dst-cursor dst)
      ;; The delay slot initializes the source cursor even when the bulk loop is skipped.
      (b.lt tail-count 0 quad-copy-tail :delay (set! src-cursor src))
      (label quad-copy-loop)
      (nop!)
      (l.q quad0 src-cursor)
      (nop!)
      (l.q quad1 src-cursor 16)
      (-! remaining 4)
      (l.q quad2 src-cursor 32)
      (&+! dst-cursor 64)
      (l.q quad3 src-cursor 48)
      (&+! src-cursor 64)
      (s.q quad0 dst-cursor -64)
      (set! tail-count (- remaining 4))
      (s.q quad1 dst-cursor -48)
      (nop!)
      (s.q quad2 dst-cursor -32)
      ;; The final store occupies the loop branch delay slot.
      (b.ge tail-count 0 quad-copy-loop :delay (s.q quad3 dst-cursor -16))
      (label quad-copy-tail)
      (b.z remaining quad-copy-done :delay (l.q quad0 src-cursor))
      (&+! src-cursor 16)
      (&+! dst-cursor 16)
      (-! remaining 1)
      (s.q quad0 dst-cursor -16)
      (b.z remaining quad-copy-done :delay (l.q quad0 src-cursor))
      (&+! src-cursor 16)
      (&+! dst-cursor 16)
      (-! remaining 1)
      (s.q quad0 dst-cursor -16)
      (b.z remaining quad-copy-done :delay (l.q quad0 src-cursor))
      (&+! src-cursor 16)
      (&+! dst-cursor 16)
      (-! remaining 1)
      (s.q quad0 dst-cursor -16)
      (b.z remaining quad-copy-done :delay (l.q quad0 src-cursor))
      (&+! src-cursor 16)
      (&+! dst-cursor 16)
      ;; The unrolled tail leaves its final count update dead.
      (set! tail-count (- remaining 1))
      (s.q quad0 dst-cursor -16)
      (label quad-copy-done)
      (return (none))))
  ;; The PC copy has no branch delay slots or EE load/store scheduling to preserve.
  (qmem-copy<-! dst src (* qwc 16))
  (none))

(defun-recursive fact int ((x int))
  "Return x factorial."
  (if (= x 1) 1 (* x (fact (+ x -1)))))

;;;;;;;;;;;;;;;;;;;;;;;;
;; printing
;;;;;;;;;;;;;;;;;;;;;;;;

;; the column that will be printed to by format.
(define *print-column* (the binteger 0))

;; note: normal use of print/inspect will have the compiler pick the appropriate method
;; for non-basics.  However, it may be useful to have print/inpsect available as a function
;; as well, allowing you to use it as a function pointer.
;; in this case, we can only do the right thing on boxed objects.

(defun print ((object object))
  "Print a boxed object without a trailing newline."
  ;; note that we use rtype-of, which works for pair, basic, and binteger.
  ((method-of-type (rtype-of object) print) object))

(defmacro printl (this)
  "Print out a boxed object and a newline.
   Note: we define both a macro and a function on purpose.
   The compiler will use the macro over the function, which will
   allow it to pick the correct print method for non-boxed objects"
  `(begin
    (print ,this)
    (format #t "~%")
    ,this))

(defun printl ((object object))
  "Print a boxed object followed by a newline."
  (let ((value object)) ((method-of-type (rtype-of value) print) value))
  (format #t "~%")
  object)

(defun inspect ((object object))
  "Print a detailed representation of a boxed object."
  ((method-of-type (rtype-of object) inspect) object))

;;;;;;;;;;;;;;;;;;;;;
;; debug utils
;;;;;;;;;;;;;;;;;;;;;

(defun-debug mem-print ((data (pointer uint32)) (word-count int))
  "Print word-count 32-bit words to the runtime output in groups of four."
  (dotimes (current-qword (/ word-count 4))
    (format 0
            "~X: ~X ~X ~X ~X~%"
            (&-> data (* current-qword 4))
            (-> data (* current-qword 4))
            (-> data (+ (* current-qword 4) 1))
            (-> data (+ (* current-qword 4) 2))
            (-> data (+ (* current-qword 4) 3))))
  #f)

;; not sure what this is.
(define *trace-list* '())

(defun print-tree-bitmask ((bits int) (count int))
  "Print one indentation row for a process-tree diagram from the active-column bitmask."
  (dotimes (i count)
    (if (zero? (logand bits 1)) (format #t "    ") (format #t "|   "))
    (set! bits (shr bits 1)))
  #f)

(defun breakpoint-range-set! ((debug-control uint) (break-address uint) (address-mask uint))
  "Configure the EE data-address breakpoint registers."
  (#unless PC_PORT
    (m cop0-debug debug-control)
    (m dab break-address)
    (m dabm address-mask)
    (return 0))
  ;; The EE breakpoint registers have no PC equivalent.
  (format 0 "breakpoint-range-set! not supported in OpenGOAL~%")
  0)

;;;;;;;;;;;;;;;;;;;;;;;
;; valid
;;;;;;;;;;;;;;;;;;;;;;;

;; The PC runtime keeps the GOAL symbol table in r14 with the same 64 KiB window as the EE.
(defmacro start-of-symbol-table ()
  `(rlet ((st :reg r14 :reset-here #t :type uint)) (the uint (- st 32768))))

(defmacro end-of-symbol-table ()
  `(rlet ((st :reg r14 :reset-here #t :type uint)) (the uint (+ st 32768))))

;; recursive, so needs to be forward declared with return type.
(define-extern valid? (function object type basic basic object symbol))

(defun valid? ((this object) (expected-type type) (name basic) (allow-false basic) (print-dest object))
  "Check whether object is a valid GOAL object of expected-type. Passing #f as expected-type only checks for a four-byte-aligned address in GOAL memory. Pass structure for a structure, which also requires 16-byte alignment; packed inline structures therefore do not pass. More specific expected types accept their subtypes. allow-false accepts #f as a null reference. name is used in error output, and a false name suppresses errors."
  (local-vars (in-goal-mem symbol) (v1-33 symbol))
  ;; first, check if we are even in valid memory. This is the start of the symbol table to the end of RAM.
  ;; (note, this will fail stuff like the debug and global heap info objects, which aren't in GOAL heaps.)
  (set! in-goal-mem (and (>= (the-as uint this) (start-of-symbol-table)) (< (the-as uint this) END_OF_MEMORY)))
  (cond
    ((not expected-type)
     ;; we didn't get an expected type, just check the alignment and address.
     (cond
       ((nonzero? (logand (the-as int this) 3))
        ;; alignment is bad!
        (if name (format print-dest "ERROR: object #x~X ~S is not a valid object (misaligned)~%" this name))
        '#f)
       ((not in-goal-mem)
        ;; address isn't within the memory we expect.
        (if name (format print-dest "ERROR: object #x~X ~S is not a valid object (bad address)~%" this name))
        '#f)
       ;; otherwise, we're good!
       (else '#t))) ;; end (not expected-type) check
    ((and allow-false (not this))
     ;; we got a false, but its allowed!
     ;; note that we don't reject falses otherwise, as false is a perfectly valid symbol.
     #t)
    (else
     (cond
       ((= expected-type structure)
        ;; no runtime type info, check alignment (16-bytes for a heap allocated or non-packed structure)
        (cond
          ((nonzero? (logand (the-as int this) 15))
           (if name
             (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" this name expected-type))
           '#f)
          ((or (not in-goal-mem) (< (the-as uint this) (end-of-symbol-table)))
           ;; structures should never be in the symbol table, they have a slightly stricter allowed memory range.
           (if name
             (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (bad address)~%" this name expected-type))
           '#f)
          (else '#t)) ;; end structure check
        )
       ((= expected-type pair)
        ;; pair alignment is 8 bytes + 2.
        (cond
          ((!= (logand (the-as int this) 7) PAIR_OFFSET)
           (if name
             (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" this name expected-type))
           '#f)
          ((not in-goal-mem)
           ;; the empty pair is in the symbol table, so we allow anything in GOAL memory.
           (if name
             (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (bad address)~%" this name expected-type))
           '#f)
          ;; pass!
          (else '#t)))
       ((= expected-type binteger)
        (cond
          ;; binteger has 0 in the lower 3 bits.
          ((zero? (logand (the-as int this) 7)) '#t)
          (else
           (if name
             (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" this name expected-type))
           '#f)))
       ;; now we assume desired type is a basic.
       ((!= (logand (the-as int this) 7) BASIC_OFFSET)
        (if name
          (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" this name expected-type))
        '#f)
       ;; basics can be in the symbol table (basics are symbols...)
       ((not in-goal-mem)
        (if name
          (format print-dest "ERROR: object #x~X ~S is not a valid object of type '~A' (bad address)~%" this name expected-type))
        '#f)
       ((and (= expected-type type) (!= (rtype-of this) type))
        ;; special case for type, check the runtime type of the object and be done.
        (if name
          (format print-dest
                  "ERROR: object #x~X ~S is not a valid object of type '~A' (invalid type #x~X)~%"
                  this
                  name
                  expected-type
                  (rtype-of this)))
        '#f)
       (else
        ;; otherwise... we want to check and see if the type is actually a type.
        ;; we use valid? to do this check.
        ;; avoid infinite recursion by skipping this check if the expected-type is type.
        (cond
          ((and (!= expected-type type) (not (valid? (rtype-of this) type '#f '#t 0)))
           (if name
             ;; note: print the invalid type as an address in case it's unprintable.
             (format print-dest
                     "ERROR: object #x~X ~S is not a valid object of type '~A' (invalid type #x~X)~%"
                     this
                     name
                     expected-type
                     (rtype-of this)))
           '#f)
          ((not (type-type? (rtype-of this) expected-type))
           ;; type check failed.
           (if name
             (format print-dest
                     "ERROR: object #x~X ~S is not a valid object of type '~A' (is type '~A' instead)~%"
                     this
                     name
                     expected-type
                     (rtype-of this)))
           '#f)
          ((= expected-type symbol)
           ;; got a symbol, expecting to be in the symbol table.
           (cond
             ((>= (the-as uint this) (end-of-symbol-table))
              (if name
                (format print-dest
                        "ERROR: object #x~X ~S is not a valid object of type '~A' (not in symbol table)~%"
                        this
                        name
                        expected-type))
              '#f)
             (else '#t)))
          ;; not a symbol, so expecting to be outside st.
          ((< (the-as uint this) (end-of-symbol-table))
           (if name
             (format print-dest
                     "ERROR: object #x~X ~S is not a valid object of type '~A' (inside symbol table)~%"
                     this
                     name
                     expected-type))
           '#f)
          (else '#t)))))))

;;;;;;;;;;;;;;;;;;;;;;;
;; PC Port asm macros
;;;;;;;;;;;;;;;;;;;;;;;
(#when PC_PORT
  ;; SYNC is an EE instruction that waits for various memory access and DMA to be completed
  ;; DMA will be instant in the PC port, so these are no longer necessary
  (fake-asm .sync.l)
  (fake-asm .sync.p)
  ;; Copies the contents of a cop0 (system control) register to a gpr
  (fake-asm .mfc0 dest src)
  ;; Copies the contents of a gpr to a cop0 (system control) register
  (fake-asm .mtc0 dest src))

;;;;;;;;;;;;;;;;;;;;;;;;
;; Decompiler Macros
;;;;;;;;;;;;;;;;;;;;;;;;

;; inserted by the decompiler for assembly branches.
(defmacro b! (pred destination &key (delay '()) &key (likely-delay '()))
  "Branch!"
  ;; evaluate the predicate
  `(let ((should-branch ,pred))
    ;; normal delay slot:
    ,delay
    (when should-branch
      ,likely-delay
      (goto ,destination))))

;; the decompiler may fail to recognize setting fields of a 128-bit bitfield
;; and will rely on this macro:
(defmacro copy-and-set-field (original field-name field-value)
  `(let ((temp-copy ,original)) (set! (-> temp-copy ,field-name) ,field-value) temp-copy))

;; inserted by the decompiler if a c->goal bool conversion can't be compacted into a single
;; expression.
(defmacro cmove-#f-zero (dest condition src)
  `(if (zero? ,condition) (set! ,dest #f) (set! ,dest ,src)))

(defmacro empty-form ()
  `(none))

;;;;;;;;;;;;;;;;;;;;
;; Profiler Macros
;;;;;;;;;;;;;;;;;;;;

(defmacro profiler-instant-event (name)
  "Record an 'instant' event in the profile.
   This can be used however you'd like, but there should be a
   'ROOT' event logged every now and then (like once per frame)
   when no timed events are in progress, to allow the profiler
   to correctly recover the event stack."
  `(#when PC_PROFILER_ENABLE
    (pc-prof ,name (pc-prof-event instant))))

(defmacro profiler-start-event (name)
  "Start a timed event with the given name."
  `(#when PC_PROFILER_ENABLE
    (pc-prof ,name (pc-prof-event begin))))

(defmacro profiler-end-event ()
  "End the most recently started event that hasn't been stopped yet.
   It is up to you to correctly balance the starts/ends, otherwise
   the profiling data will be corrupted."
  `(#when PC_PROFILER_ENABLE
    (pc-prof "" (pc-prof-event end))))

(defmacro with-profiler (name &rest body)
  "Execute the body in a named profiler block.
   Do not `return` or `go` from inside this block,
   otherwise the end will be skipped."
  `(#if PC_PROFILER_ENABLE
    (begin
      (pc-prof ,name (pc-prof-event begin))
      ,@body
      (pc-prof ,name (pc-prof-event end)))
    (begin
      ,@body)))