mirror of
https://github.com/open-goal/jak-project.git
synced 2024-10-20 21:27:52 -04:00
dc652d10c5
* add comments * oops * format' * spelling is hard
1390 lines
37 KiB
Common Lisp
1390 lines
37 KiB
Common Lisp
;;-*-Lisp-*-
|
|
(in-package goal)
|
|
|
|
;; name: gcommon.gc
|
|
;; name in dgo: gcommon
|
|
;; dgos: KERNEL
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; 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 #t)
|
|
|
|
;; 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_TO_STRING_OFFSET in goal_constants.h
|
|
(defconstant SYM_TO_STRING_OFFSET #xff37)
|
|
|
|
(defmacro symbol->string (sym)
|
|
"Convert a symbol to a goal string."
|
|
`(-> (the-as (pointer string) (+ SYM_TO_STRING_OFFSET (the-as int ,sym))))
|
|
)
|
|
|
|
;; pointers larger than this are invalid by valid?
|
|
(defconstant END_OF_MEMORY #x8000000)
|
|
|
|
(defun identity ((arg0 object))
|
|
"Return the input. Works for any 64-bit value."
|
|
arg0
|
|
)
|
|
|
|
(defun 1/ ((arg0 float))
|
|
"Floating point reciprocal"
|
|
(declare (inline))
|
|
(/ 1.0 arg0)
|
|
)
|
|
|
|
;; These functions exist a function objects that wrap the compiler's built-in operators.
|
|
|
|
(defun + ((arg0 int) (arg1 int))
|
|
"Add two integers (64-bit)."
|
|
(+ arg0 arg1)
|
|
)
|
|
|
|
(defun - ((arg0 int) (arg1 int))
|
|
"Subtract two integers (64-bit)."
|
|
(- arg0 arg1)
|
|
)
|
|
|
|
(defun * ((arg0 int) (arg1 int))
|
|
"Multiply two integers (32-bit)"
|
|
(* arg0 arg1)
|
|
)
|
|
|
|
(defun / ((arg0 int) (arg1 int))
|
|
"Divide two integers (32-bit, signed)"
|
|
(/ arg0 arg1)
|
|
)
|
|
|
|
(defun mod ((arg0 int) (arg1 int))
|
|
"Integer mod (signed, 32-bit)"
|
|
(mod arg0 arg1)
|
|
)
|
|
|
|
(defun rem ((arg0 int) (arg1 int))
|
|
"Integer mod (signed, 32-bit). Even though it's called rem, it behaves the same as mod."
|
|
(mod arg0 arg1)
|
|
)
|
|
|
|
|
|
(defun ash ((value int) (shift-amount int))
|
|
"Arithmetic shift value by shift-amount.
|
|
A positive shift-amount will shift to the left and a negative will shift to the right."
|
|
;; OpenGOAL does not support ash in the compiler, so we implement it here as an inline function.
|
|
(declare (inline))
|
|
(if (> shift-amount 0)
|
|
(shl value shift-amount)
|
|
(sar value (- shift-amount))
|
|
)
|
|
)
|
|
|
|
(defun abs ((a int))
|
|
"Take the absolute value of a 64-bit signed integer"
|
|
(declare (inline))
|
|
;; OpenGOAL doesn't support abs, so we implement it here.
|
|
(if (> a 0)
|
|
a
|
|
(- a)
|
|
)
|
|
)
|
|
|
|
(defun min ((a int) (b int))
|
|
"Compute minimum of two 64-bit signed integers."
|
|
(declare (inline))
|
|
;; OpenGOAL doesn't support min, so we implement it here.
|
|
(if (> a b) b a)
|
|
)
|
|
|
|
(defun max ((a int) (b int))
|
|
"Compute maximum of two 64-bit signed integer."
|
|
(declare (inline))
|
|
;; OpenGOAL doesn't support max so we implement it here.
|
|
(if (> a b) a b)
|
|
)
|
|
|
|
(defun logior ((arg0 int) (arg1 int))
|
|
"Logical or (64-bit)"
|
|
(logior arg0 arg1)
|
|
)
|
|
|
|
(defun logand ((arg0 int) (arg1 int))
|
|
"Logical and (64-bit)"
|
|
(logand arg0 arg1)
|
|
)
|
|
|
|
(defun lognor ((a int) (b int))
|
|
"Compute not or (64-bit)."
|
|
;; Note - MIPS has a 'nor' instruction, but x86 doesn't.
|
|
;; the OpenGOAL x86 compiler therefore doesn't have a nor operation,
|
|
;; so lognor is implemented by this inline function instead.
|
|
(declare (inline))
|
|
(lognot (logior a b))
|
|
)
|
|
|
|
(defun logxor ((arg0 int) (arg1 int))
|
|
"Logical exclusive or (64-bit)"
|
|
(logxor arg0 arg1)
|
|
)
|
|
|
|
(defun lognot ((arg0 int))
|
|
"Logical not (64-bit)"
|
|
(lognot arg0)
|
|
)
|
|
|
|
(defun false-func ()
|
|
"Return #f."
|
|
#f
|
|
)
|
|
|
|
(defun true-func ()
|
|
"Return #t."
|
|
#t
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; format
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; The "format" function is implemented in C but is called _format.
|
|
;; This defines the format function to point to the same thing as _format.
|
|
(define format _format)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; numeric types
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; vec4s: 4 floats packed into a 128-bit integer register. This is rarely used.
|
|
(deftype vec4s (uint128)
|
|
((x float :offset 0 :size 32)
|
|
(y float :offset 32 :size 32)
|
|
(z float :offset 64 :size 32)
|
|
(w float :offset 96 :size 32)
|
|
)
|
|
:method-count-assert 9
|
|
:size-assert #x10
|
|
:flag-assert #x900000010
|
|
)
|
|
|
|
(defmethod print vec4s ((obj vec4s))
|
|
"Custom print for vec4s that prints the 4 values."
|
|
(format #t "#<vector ~F ~F ~F ~F @ #x~X>"
|
|
(-> obj x)
|
|
(-> obj y)
|
|
(-> obj z)
|
|
(-> obj w)
|
|
obj)
|
|
obj
|
|
)
|
|
|
|
;; vector: main 4-element floating point vector.
|
|
(deftype vector (structure)
|
|
((data float 4 :offset-assert 0)
|
|
(x float :offset 0)
|
|
(y float :offset 4)
|
|
(z float :offset 8)
|
|
(w float :offset 12)
|
|
(quad uint128 :offset 0)
|
|
)
|
|
:method-count-assert 9
|
|
:size-assert #x10
|
|
:flag-assert #x900000010
|
|
)
|
|
|
|
(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)
|
|
)
|
|
)
|
|
|
|
;; bfloat: boxed float type. A floating point number with type information.
|
|
;; It's a heap allocated basic.
|
|
(deftype bfloat (basic)
|
|
((data float :offset-assert 4)
|
|
)
|
|
:method-count-assert 9
|
|
:size-assert #x8
|
|
:flag-assert #x900000008
|
|
)
|
|
|
|
(defmethod print bfloat ((obj bfloat))
|
|
(format #t "~f" (-> obj data))
|
|
obj
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Type System
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defmethod asize-of type ((obj type))
|
|
"Get the size in memory of a type. The value calculated here is wrong."
|
|
(the-as int (logand (the-as uint #xfffffff0) (+ (* (-> obj allocated-length) 4) 43)))
|
|
)
|
|
|
|
(defun basic-type? ((arg0 basic) (arg1 type))
|
|
"Is the given basic an object of the given type?"
|
|
(let ((v1-0 (-> arg0 type))
|
|
(a0-1 object)
|
|
)
|
|
(until (= v1-0 a0-1)
|
|
(if (= v1-0 arg1)
|
|
(return #t)
|
|
)
|
|
(set! v1-0 (-> v1-0 parent))
|
|
)
|
|
)
|
|
#f
|
|
)
|
|
|
|
(defun type-type? ((arg0 type) (arg1 type))
|
|
"Is the given type equal to, or a child of, the second type?"
|
|
(let ((v1-0 object))
|
|
(if (= arg1 v1-0)
|
|
(return #t)
|
|
)
|
|
(until (or (= arg0 v1-0) (zero? arg0))
|
|
(if (= arg0 arg1)
|
|
(return #t)
|
|
)
|
|
(set! arg0 (-> arg0 parent))
|
|
)
|
|
)
|
|
#f
|
|
)
|
|
|
|
(defun type? ((arg0 object) (arg1 type))
|
|
"Is the given object an object of the given type? Works for any boxed object (basic, symbol, binteger, pair)."
|
|
(let ((v1-0 object)
|
|
(a0-1 (rtype-of arg0))
|
|
)
|
|
(if (= arg1 v1-0)
|
|
(return #t)
|
|
)
|
|
(until (or (= a0-1 v1-0) (zero? a0-1))
|
|
(if (= a0-1 arg1)
|
|
(return #t)
|
|
)
|
|
(set! a0-1 (-> a0-1 parent))
|
|
)
|
|
)
|
|
#f
|
|
)
|
|
|
|
(defun find-parent-method ((arg0 type) (arg1 int))
|
|
"Go up the type tree and find the first parent type that has a different implementation for the given method."
|
|
(local-vars (v0-0 function))
|
|
(let ((v1-2 (-> arg0 method-table arg1)))
|
|
(until (!= v0-0 v1-2)
|
|
(if (= arg0 object)
|
|
(return nothing)
|
|
)
|
|
(set! arg0 (-> arg0 parent))
|
|
(set! v0-0 (-> arg0 method-table arg1))
|
|
(if (zero? v0-0)
|
|
(return nothing)
|
|
)
|
|
)
|
|
)
|
|
v0-0
|
|
)
|
|
|
|
(defun ref ((arg0 object) (arg1 int))
|
|
"Get the n-th item in a linked list. No range checking."
|
|
(dotimes (v1-0 arg1)
|
|
(nop!)
|
|
(nop!)
|
|
(set! arg0 (cdr arg0))
|
|
)
|
|
(car arg0)
|
|
)
|
|
|
|
(defmethod length pair ((obj pair))
|
|
"Get the length of a linked list."
|
|
(local-vars (v0-0 int))
|
|
(cond
|
|
((null? obj)
|
|
(set! v0-0 0)
|
|
)
|
|
(else
|
|
(let ((v1-1 (cdr obj)))
|
|
(set! v0-0 1)
|
|
(while (and (not (null? v1-1)) (pair? v1-1))
|
|
(+! v0-0 1)
|
|
(set! v1-1 (cdr v1-1))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
v0-0
|
|
)
|
|
|
|
(defmethod asize-of pair ((obj pair))
|
|
"Get the size in memory of a pair."
|
|
(the-as int (-> pair size))
|
|
)
|
|
|
|
(defun last ((arg0 object))
|
|
"Get the last object in a list."
|
|
(let ((v0-0 arg0))
|
|
(while (not (null? (cdr v0-0)))
|
|
(nop!)
|
|
(nop!)
|
|
(set! v0-0 (cdr v0-0))
|
|
)
|
|
v0-0
|
|
)
|
|
)
|
|
|
|
(defun member ((arg0 object) (arg1 object))
|
|
"Is obj in the list lst? Returns pair with obj as its car, or #f if not found."
|
|
(let ((v1-0 arg1))
|
|
(while (not (or (null? v1-0) (= (car v1-0) arg0)))
|
|
(set! v1-0 (cdr v1-0))
|
|
)
|
|
(if (not (null? v1-0))
|
|
v1-0
|
|
)
|
|
)
|
|
)
|
|
|
|
;; need to forward declare this, we haven't loaded the string library yet.
|
|
(define-extern name= (function object object symbol))
|
|
|
|
(defun nmember ((arg0 basic) (arg1 object))
|
|
"Is obj in the list lst? Check with the name= function."
|
|
(while (not (or (null? arg1) (name= (car arg1) arg0)))
|
|
(set! arg1 (cdr arg1))
|
|
)
|
|
(if (not (null? arg1))
|
|
arg1
|
|
)
|
|
)
|
|
|
|
(defun assoc ((arg0 object) (arg1 object))
|
|
"Is item in the association list alist?
|
|
Returns the key-value pair."
|
|
(let ((v1-0 arg1))
|
|
(while (not (or (null? v1-0) (= (car (car v1-0)) arg0)))
|
|
(set! v1-0 (cdr v1-0))
|
|
)
|
|
(if (not (null? v1-0))
|
|
(car v1-0)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun assoce ((arg0 object) (arg1 object))
|
|
"Is there an entry with key item in the association list alist?
|
|
Returns the key-value pair.
|
|
Treats a key of 'else like an else case"
|
|
(let ((v1-0 arg1))
|
|
(while (not (or (null? v1-0) (= (car (car v1-0)) arg0) (= (car (car v1-0)) 'else)))
|
|
(set! v1-0 (cdr v1-0))
|
|
)
|
|
(if (not (null? v1-0))
|
|
(car v1-0)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun nassoc ((arg0 string) (arg1 object))
|
|
"Is there an entry named item-name in the association list alist?
|
|
Checks name with nmember or name= so you can have multiple keys.
|
|
Returns the ([key|(key..)] . value) pair."
|
|
(while (not (or (null? arg1) (let ((a1-1 (car (car arg1))))
|
|
(if (pair? a1-1)
|
|
(nmember arg0 a1-1)
|
|
(name= (the-as basic a1-1) arg0)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(set! arg1 (cdr arg1))
|
|
)
|
|
(if (not (null? arg1))
|
|
(car arg1)
|
|
)
|
|
)
|
|
|
|
(defun nassoce ((arg0 string) (arg1 object))
|
|
"Is there an entry named item-name in the association list alist?
|
|
Checks name with nmember for multiple keys or name= for single.
|
|
Allows else as a single key that always matches"
|
|
(while (not (or (null? arg1) (let ((s4-0 (car (car arg1))))
|
|
(if (pair? s4-0)
|
|
(nmember arg0 s4-0)
|
|
(or (name= (the-as basic s4-0) arg0) (= s4-0 'else))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(set! arg1 (cdr arg1))
|
|
)
|
|
(if (not (null? arg1))
|
|
(car arg1)
|
|
)
|
|
)
|
|
|
|
(defun append! ((arg0 object) (arg1 object))
|
|
"Append back to front, return the combined list."
|
|
(cond
|
|
((null? arg0)
|
|
arg1
|
|
)
|
|
(else
|
|
(let ((v1-1 arg0))
|
|
(while (not (null? (cdr v1-1)))
|
|
(nop!)
|
|
(nop!)
|
|
(set! v1-1 (cdr v1-1))
|
|
)
|
|
(if (not (null? v1-1))
|
|
(set! (cdr v1-1) arg1)
|
|
)
|
|
)
|
|
arg0
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun delete! ((arg0 object) (arg1 object))
|
|
"Remove the first occurance of item from lst (where item is actual a pair in the list)"
|
|
(the-as pair
|
|
(cond
|
|
((= arg0 (car arg1))
|
|
(cdr arg1)
|
|
)
|
|
(else
|
|
(let ((v1-1 arg1)
|
|
(a2-0 (cdr arg1))
|
|
)
|
|
(while (not (or (null? a2-0) (= (car a2-0) arg0)))
|
|
(set! v1-1 a2-0)
|
|
(set! a2-0 (cdr a2-0))
|
|
)
|
|
(if (not (null? a2-0))
|
|
(set! (cdr v1-1) (cdr a2-0))
|
|
)
|
|
)
|
|
arg1
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun delete-car! ((arg0 object) (arg1 object))
|
|
"Remove the first first occurance of an element from the list where (car elt) is item."
|
|
(cond
|
|
((= arg0 (car (car arg1)))
|
|
(cdr arg1)
|
|
)
|
|
(else
|
|
(let ((v1-2 arg1)
|
|
(a2-0 (cdr arg1))
|
|
)
|
|
(while (not (or (null? a2-0) (= (car (car a2-0)) arg0)))
|
|
(set! v1-2 a2-0)
|
|
(set! a2-0 (cdr a2-0))
|
|
)
|
|
(if (not (null? a2-0))
|
|
(set! (cdr v1-2) (cdr a2-0))
|
|
)
|
|
)
|
|
arg1
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun insert-cons! ((arg0 object) (arg1 object))
|
|
"Update an association list to have the given (key . value) pair kv.
|
|
If it already exists in the list, remove it.
|
|
DANGER: this function allocates memory on the global heap."
|
|
(let ((a3-0 (delete-car! (car arg0) arg1)))
|
|
(cons arg0 a3-0)
|
|
)
|
|
)
|
|
|
|
(defun sort ((arg0 pair) (arg1 (function object object object)))
|
|
"Sort a list, using compare-func to compare elements.
|
|
The comparison function can return either an integer or a true/false.
|
|
For integers, use a positive number to represent first > second
|
|
Ex: (sort lst -) will sort in ascending order
|
|
For booleans, you must explicitly use TRUE and not a truthy value.
|
|
Ex: (sort my-list (lambda ((x int) (y int)) (< x y))) will sort ascending.
|
|
NOTE: if you use an integer, don't accidentally return TRUE."
|
|
(let ((s4-0 -1))
|
|
(while (nonzero? s4-0)
|
|
(set! s4-0 0)
|
|
(let ((s3-0 arg0))
|
|
(while (not (or (null? (cdr s3-0)) (not (pair? (cdr s3-0)))))
|
|
(let* ((s2-0 (car s3-0))
|
|
(s1-0 (car (cdr s3-0)))
|
|
(v1-1 (arg1 s2-0 s1-0))
|
|
)
|
|
(when (and (or (not v1-1) (> (the-as int v1-1) 0)) (!= v1-1 #t))
|
|
(+! s4-0 1)
|
|
(set! (car s3-0) s1-0)
|
|
(set! (car (cdr s3-0)) s2-0)
|
|
)
|
|
)
|
|
(set! s3-0 (cdr s3-0))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
arg0
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; 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 :offset-assert 4)
|
|
(allocated-length int32 :offset-assert 8)
|
|
(_data uint8 :dynamic :offset 16)
|
|
)
|
|
:method-count-assert 9
|
|
:size-assert #x10
|
|
:flag-assert #x900000010
|
|
(:methods
|
|
(new (symbol type int) _type_ 0)
|
|
)
|
|
)
|
|
|
|
(defmethod new inline-array-class ((allocation symbol) (type-to-make type) (arg0 int))
|
|
"Allocate a new inline-array-class object with room for the given number of objects.
|
|
Both length and allocated-length are set to the given size"
|
|
(let ((v0-0 (object-new
|
|
allocation
|
|
type-to-make
|
|
(the-as int (+ (-> type-to-make size) (* (the-as uint arg0) (-> type-to-make heap-base))))
|
|
)
|
|
)
|
|
)
|
|
(when (nonzero? v0-0)
|
|
(set! (-> v0-0 length) arg0)
|
|
(set! (-> v0-0 allocated-length) arg0)
|
|
)
|
|
v0-0
|
|
)
|
|
)
|
|
|
|
(defmethod length inline-array-class ((obj inline-array-class))
|
|
"Get the length of the inline-array-class. This is the length field,
|
|
not how much storage there is"
|
|
(-> obj length)
|
|
)
|
|
|
|
(defmethod asize-of inline-array-class ((obj inline-array-class))
|
|
"Get the size in memory of an inline-array-class."
|
|
(the-as int (+ (-> obj type size) (* (-> obj allocated-length) (the-as int (-> obj 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) (arg0 type) (arg1 int))
|
|
"Allocate a new array to hold len 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 ((v0-1 (object-new
|
|
allocation
|
|
type-to-make
|
|
(the-as int (+ (-> type-to-make size) (* arg1 (if (type-type? arg0 number)
|
|
(the-as int (-> arg0 size))
|
|
4
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(set! (-> v0-1 allocated-length) arg1)
|
|
(set! (-> v0-1 length) arg1)
|
|
(set! (-> v0-1 content-type) arg0)
|
|
v0-1
|
|
)
|
|
)
|
|
|
|
(defmethod print array ((obj array))
|
|
(format #t "#(")
|
|
(cond
|
|
((type-type? (-> obj content-type) integer)
|
|
(case (-> obj content-type symbol)
|
|
(('int32)
|
|
(dotimes (s5-0 (-> obj length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-0)
|
|
"~D"
|
|
" ~D"
|
|
)
|
|
(-> (the-as (array int32) obj) s5-0)
|
|
)
|
|
)
|
|
)
|
|
(('uint32)
|
|
(dotimes (s5-1 (-> obj length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-1)
|
|
"~D"
|
|
" ~D"
|
|
)
|
|
(-> (the-as (array uint32) obj) s5-1)
|
|
)
|
|
)
|
|
)
|
|
(('int64)
|
|
(dotimes (s5-2 (-> obj length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-2)
|
|
"~D"
|
|
" ~D"
|
|
)
|
|
(-> (the-as (array int64) obj) s5-2)
|
|
)
|
|
)
|
|
)
|
|
(('uint64)
|
|
(dotimes (s5-3 (-> obj length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-3)
|
|
"#x~X"
|
|
" #x~X"
|
|
)
|
|
(-> (the-as (array uint64) obj) s5-3)
|
|
)
|
|
)
|
|
)
|
|
(('int8)
|
|
(dotimes (s5-4 (-> obj length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-4)
|
|
"~D"
|
|
" ~D"
|
|
)
|
|
(-> (the-as (array int8) obj) s5-4)
|
|
)
|
|
)
|
|
)
|
|
(('uint8)
|
|
(dotimes (s5-5 (-> obj length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-5)
|
|
"~D"
|
|
" ~D"
|
|
)
|
|
(-> (the-as (array uint8) obj) s5-5)
|
|
)
|
|
)
|
|
)
|
|
(('int16)
|
|
(dotimes (s5-6 (-> obj length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-6)
|
|
"~D"
|
|
" ~D"
|
|
)
|
|
(-> (the-as (array int16) obj) s5-6)
|
|
)
|
|
)
|
|
)
|
|
(('uint16)
|
|
(dotimes (s5-7 (-> obj length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-7)
|
|
"~D"
|
|
" ~D"
|
|
)
|
|
(-> (the-as (array uint16) obj) s5-7)
|
|
)
|
|
)
|
|
)
|
|
(('uint128 'int128)
|
|
(dotimes (s5-8 (-> obj length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-8)
|
|
"#x~X"
|
|
" #x~X"
|
|
)
|
|
(-> (the-as (array uint128) obj) s5-8)
|
|
)
|
|
)
|
|
)
|
|
(else
|
|
(dotimes (s5-9 (-> obj length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-9)
|
|
"~D"
|
|
" ~D"
|
|
)
|
|
(-> (the-as (array int32) obj) s5-9)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
((= (-> obj content-type) float)
|
|
(dotimes (s5-10 (-> obj length))
|
|
(if (zero? s5-10)
|
|
(format #t "~f" (-> (the-as (array float) obj) s5-10))
|
|
(format #t " ~f" (-> (the-as (array float) obj) s5-10))
|
|
)
|
|
)
|
|
)
|
|
(else
|
|
(dotimes (s5-11 (-> obj length))
|
|
(if (zero? s5-11)
|
|
(format #t "~A" (-> (the-as (array basic) obj) s5-11))
|
|
(format #t " ~A" (-> (the-as (array basic) obj) s5-11))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(format #t ")")
|
|
obj
|
|
)
|
|
|
|
(defmethod inspect array ((obj array))
|
|
"Inspect an array"
|
|
(format #t "[~8x] ~A~%" obj (-> obj type))
|
|
(format #t "~Tallocated-length: ~D~%" (-> obj allocated-length))
|
|
(format #t "~Tlength: ~D~%" (-> obj length))
|
|
(format #t "~Tcontent-type: ~A~%" (-> obj content-type))
|
|
(format #t "~Tdata[~D]: @ #x~X~%" (-> obj allocated-length) (-> obj data))
|
|
(cond
|
|
((and (= (logand (the-as int (-> obj content-type)) 7) 4) (type-type? (-> obj content-type) integer))
|
|
(case (-> obj content-type symbol)
|
|
(('int32)
|
|
(dotimes (s5-0 (-> obj length))
|
|
(format #t "~T [~D] ~D~%" s5-0 (-> (the-as (array int32) obj) s5-0))
|
|
)
|
|
)
|
|
(('uint32)
|
|
(dotimes (s5-1 (-> obj length))
|
|
(format #t "~T [~D] ~D~%" s5-1 (-> (the-as (array uint32) obj) s5-1))
|
|
)
|
|
)
|
|
(('int64)
|
|
(dotimes (s5-2 (-> obj length))
|
|
(format #t "~T [~D] ~D~%" s5-2 (-> (the-as (array int64) obj) s5-2))
|
|
)
|
|
)
|
|
(('uint64)
|
|
(dotimes (s5-3 (-> obj length))
|
|
(format #t "~T [~D] #x~X~%" s5-3 (-> (the-as (array uint64) obj) s5-3))
|
|
)
|
|
)
|
|
(('int8)
|
|
(dotimes (s5-4 (-> obj length))
|
|
(format #t "~T [~D] ~D~%" s5-4 (-> (the-as (array int8) obj) s5-4))
|
|
)
|
|
)
|
|
(('uint8)
|
|
(dotimes (s5-5 (-> obj length))
|
|
(format #t "~T [~D] ~D~%" s5-5 (-> (the-as (array int8) obj) s5-5))
|
|
)
|
|
)
|
|
(('int16)
|
|
(dotimes (s5-6 (-> obj length))
|
|
(format #t "~T [~D] ~D~%" s5-6 (-> (the-as (array int16) obj) s5-6))
|
|
)
|
|
)
|
|
(('uint16)
|
|
(dotimes (s5-7 (-> obj length))
|
|
(format #t "~T [~D] ~D~%" s5-7 (-> (the-as (array uint16) obj) s5-7))
|
|
)
|
|
)
|
|
(('int128 'uint128)
|
|
(dotimes (s5-8 (-> obj length))
|
|
(format #t "~T [~D] #x~X~%" s5-8 (-> (the-as (array uint128) obj) s5-8))
|
|
)
|
|
)
|
|
(else
|
|
(dotimes (s5-9 (-> obj length))
|
|
(format #t "~T [~D] ~D~%" s5-9 (-> (the-as (array int32) obj) s5-9))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
((= (-> obj content-type) float)
|
|
(dotimes (s5-10 (-> obj length))
|
|
(format #t "~T [~D] ~f~%" s5-10 (-> (the-as (array float) obj) s5-10))
|
|
)
|
|
)
|
|
(else
|
|
(dotimes (s5-11 (-> obj length))
|
|
(format #t "~T [~D] ~A~%" s5-11 (-> (the-as (array basic) obj) s5-11))
|
|
)
|
|
)
|
|
)
|
|
obj
|
|
)
|
|
|
|
(defmethod length array ((obj array))
|
|
"Get the length of an array"
|
|
(-> obj length)
|
|
)
|
|
|
|
(defmethod asize-of array ((obj array))
|
|
"Get the size in memory of an array"
|
|
(the-as
|
|
int
|
|
(+ (-> obj type size) (* (-> obj allocated-length) (if (type-type? (-> obj content-type) number)
|
|
(the-as int (-> obj content-type size))
|
|
4
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; memory manipulation
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun mem-copy! ((arg0 pointer) (arg1 pointer) (arg2 int))
|
|
"Memory copy. Not a very efficient optimization, but has no restrictions.
|
|
Increasing address copy."
|
|
(let ((v0-0 arg0))
|
|
(dotimes (v1-0 arg2)
|
|
(set! (-> (the-as (pointer uint8) arg0)) (-> (the-as (pointer uint8) arg1)))
|
|
(&+! arg0 1)
|
|
(&+! arg1 1)
|
|
)
|
|
v0-0
|
|
)
|
|
)
|
|
|
|
(defun qmem-copy<-! ((arg0 pointer) (arg1 pointer) (arg2 int))
|
|
"Memory copy by quadword. More efficient, but has restrictions:
|
|
- dst and src should be 16-byte aligned.
|
|
- size in bytes will be rounded up to 16-bytes
|
|
- Ascending address copy."
|
|
(let ((v0-0 arg0))
|
|
(countdown (v1-1 (/ (+ arg2 15) 16))
|
|
(set! (-> (the-as (pointer uint128) arg0)) (-> (the-as (pointer uint128) arg1)))
|
|
(&+! arg0 16)
|
|
(&+! arg1 16)
|
|
)
|
|
v0-0
|
|
)
|
|
)
|
|
|
|
(defun qmem-copy->! ((arg0 pointer) (arg1 pointer) (arg2 int))
|
|
"Memory copy by quadword (16-bytes). More efficient, but has restrictions:
|
|
- dst and src should be 16-byte aligned.
|
|
- size in bytes will be rounding up to nearest 16-bytes
|
|
- Descending address copy"
|
|
(let ((v0-0 arg0))
|
|
(let* ((v1-1 (/ (+ arg2 15) 16))
|
|
(a0-1 (&+ arg0 (* v1-1 16)))
|
|
(a1-1 (&+ arg1 (* v1-1 16)))
|
|
)
|
|
(while (nonzero? v1-1)
|
|
(+! v1-1 -1)
|
|
(&+! a0-1 -16)
|
|
(&+! a1-1 -16)
|
|
(set! (-> (the-as (pointer uint128) a0-1)) (-> (the-as (pointer uint128) a1-1)))
|
|
)
|
|
)
|
|
v0-0
|
|
)
|
|
)
|
|
|
|
(defun mem-set32! ((arg0 pointer) (arg1 int) (arg2 int))
|
|
"Normal memset, but by 32-bit word.
|
|
NOTE: argument order is swapped from C"
|
|
(let ((v0-0 arg0))
|
|
(dotimes (v1-0 arg1)
|
|
(set! (-> (the-as (pointer int32) arg0)) arg2)
|
|
(&+! arg0 4)
|
|
(nop!)
|
|
)
|
|
v0-0
|
|
)
|
|
)
|
|
|
|
(defun mem-or! ((arg0 pointer) (arg1 pointer) (arg2 int))
|
|
"Set the dst to (logior dst src) byte by byte.
|
|
Not very efficient."
|
|
(let ((v0-0 arg0))
|
|
(dotimes (v1-0 arg2)
|
|
(logior! (-> (the-as (pointer uint8) arg0)) (-> (the-as (pointer uint8) arg1)))
|
|
(&+! arg0 1)
|
|
(&+! arg1 1)
|
|
)
|
|
v0-0
|
|
)
|
|
)
|
|
|
|
(defun quad-copy! ((dst pointer) (src pointer) (qwc int))
|
|
"Optimized memory copy. The original is pretty clever, but this isn't."
|
|
(qmem-copy<-! dst src (* qwc 16))
|
|
(none)
|
|
)
|
|
|
|
(defun-recursive fact int ((x int))
|
|
(if (= x 1)
|
|
1
|
|
(* x (fact (+ x -1))))
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; printing
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; the column that will be printed to by format.
|
|
(define *print-column* (the-as 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/inspect 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 ((arg0 object))
|
|
"Print out any boxed object. Does NOT insert a newline."
|
|
((method-of-type (rtype-of arg0) print) arg0)
|
|
)
|
|
|
|
(defmacro printl (obj)
|
|
"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 ,obj)
|
|
(format #t "~%")
|
|
,obj
|
|
)
|
|
)
|
|
|
|
(defun printl ((arg0 object))
|
|
"Print out any boxed object and a newline at the end."
|
|
(let ((a0-1 arg0))
|
|
((method-of-type (rtype-of a0-1) print) a0-1)
|
|
)
|
|
(format #t "~%")
|
|
arg0
|
|
)
|
|
|
|
(defun inspect ((arg0 object))
|
|
"Inspect any boxed object."
|
|
((method-of-type (rtype-of arg0) inspect) arg0)
|
|
)
|
|
|
|
(defun-debug mem-print ((arg0 (pointer uint32)) (arg1 int))
|
|
"Print memory to runtime stdout by quadword.
|
|
Input count is in 32-bit words"
|
|
(dotimes (s4-0 (/ arg1 4))
|
|
(format
|
|
0
|
|
"~X: ~X ~X ~X ~X~%"
|
|
(&-> arg0 (* s4-0 4))
|
|
(-> arg0 (* s4-0 4))
|
|
(-> arg0 (+ (* s4-0 4) 1))
|
|
(-> arg0 (+ (* s4-0 4) 2))
|
|
(-> arg0 (+ (* s4-0 4) 3))
|
|
)
|
|
)
|
|
#f
|
|
)
|
|
|
|
;; unused
|
|
(define *trace-list* '())
|
|
|
|
(defun print-tree-bitmask ((arg0 int) (arg1 int))
|
|
"Print out a single entry for a process tree 'tree' diagram"
|
|
(dotimes (s4-0 arg1)
|
|
(if (zero? (logand arg0 1))
|
|
(format #t " ")
|
|
(format #t "| ")
|
|
)
|
|
(set! arg0 (shr arg0 1))
|
|
)
|
|
#f
|
|
)
|
|
|
|
(defun breakpoint-range-set! ((arg0 uint) (arg1 uint) (arg2 uint))
|
|
"Sets some debug register (COP0 Debug, dab, dabm) to break on memory access.
|
|
This is not supported in OpenGOAL."
|
|
(break!)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; valid
|
|
;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(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))
|
|
)
|
|
)
|
|
|
|
(define-extern boolean type) ;; not really... but they use it here as if it was one.
|
|
(define-extern valid? (function object type symbol symbol object symbol))
|
|
|
|
(defun valid? ((arg0 object) (arg1 type) (arg2 symbol) (arg3 symbol) (arg4 object))
|
|
"Check if the given object is valid. This will work for structures, pairs, basics, bintegers, symbols, and types.
|
|
If you set expected-type to #f, it just checks for a 4-byte aligned address that's in GOAL memory.
|
|
If you're checking a structure, set expected-type to structure. This requires 16-byte alignment
|
|
Note: packed inline structures in arrays or fields will not pass this check.
|
|
Otherwise, set it to the type you expect. More specific types will pass.
|
|
|
|
If allow-false is #t, a #f will always pass. Otherwise, #f will fail (unless you're looking for a symbol).
|
|
Use allow-false if you want to allow a 'null' reference.
|
|
|
|
The name is only used when printing out an error if the check fails.
|
|
Use a name of #f to suppress error prints.
|
|
"
|
|
(let ((v1-1
|
|
(and (>= (the-as uint arg0) (start-of-symbol-table)) (< (the-as uint arg0) END_OF_MEMORY))
|
|
)
|
|
)
|
|
(cond
|
|
((not arg1)
|
|
(cond
|
|
((logtest? (the-as int arg0) 3)
|
|
(if arg2
|
|
(format arg4 "ERROR: object #x~X ~S is not a valid object (misaligned)~%" arg0 arg2)
|
|
)
|
|
#f
|
|
)
|
|
((not v1-1)
|
|
(if arg2
|
|
(format arg4 "ERROR: object #x~X ~S is not a valid object (bad address)~%" arg0 arg2)
|
|
)
|
|
#f
|
|
)
|
|
(else
|
|
#t
|
|
)
|
|
)
|
|
)
|
|
((and arg3 (not arg0))
|
|
#t
|
|
)
|
|
((= arg1 structure)
|
|
(cond
|
|
((logtest? (the-as int arg0) 15)
|
|
(if arg2
|
|
(format arg4 "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" arg0 arg2 arg1)
|
|
)
|
|
#f
|
|
)
|
|
((or (not v1-1) (< (the-as uint arg0) (end-of-symbol-table)))
|
|
(if arg2
|
|
(format arg4 "ERROR: object #x~X ~S is not a valid object of type '~A' (bad address)~%" arg0 arg2 arg1)
|
|
)
|
|
#f
|
|
)
|
|
(else
|
|
#t
|
|
)
|
|
)
|
|
)
|
|
((= arg1 pair)
|
|
(cond
|
|
((not (pair? arg0))
|
|
(if arg2
|
|
(format arg4 "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" arg0 arg2 arg1)
|
|
)
|
|
#f
|
|
)
|
|
((not v1-1)
|
|
(if arg2
|
|
(format arg4 "ERROR: object #x~X ~S is not a valid object of type '~A' (bad address)~%" arg0 arg2 arg1)
|
|
)
|
|
#f
|
|
)
|
|
(else
|
|
#t
|
|
)
|
|
)
|
|
)
|
|
((= arg1 binteger)
|
|
(cond
|
|
((zero? (logand (the-as int arg0) 7))
|
|
#t
|
|
)
|
|
(else
|
|
(if arg2
|
|
(format arg4 "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" arg0 arg2 arg1)
|
|
)
|
|
#f
|
|
)
|
|
)
|
|
)
|
|
((or (= arg1 symbol) (= arg1 boolean))
|
|
(cond
|
|
((zero? (logand (the-as int arg0) 1))
|
|
(if arg2
|
|
(format arg4 "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" arg0 arg2 arg1)
|
|
)
|
|
#f
|
|
)
|
|
((or (not v1-1) (< (the-as int arg0) (start-of-symbol-table))(>= (the-as int arg0) (end-of-symbol-table)))
|
|
(if arg2
|
|
(format arg4 "ERROR: object #x~X ~S is not a valid object of type '~A' (bad address)~%" arg0 arg2 arg1)
|
|
)
|
|
#f
|
|
)
|
|
(else
|
|
#t
|
|
)
|
|
)
|
|
)
|
|
((!= (logand (the-as int arg0) 7) 4)
|
|
(if arg2
|
|
(format arg4 "ERROR: object #x~X ~S is not a valid object of type '~A' (misaligned)~%" arg0 arg2 arg1)
|
|
)
|
|
#f
|
|
)
|
|
((not v1-1)
|
|
(if arg2
|
|
(format arg4 "ERROR: object #x~X ~S is not a valid object of type '~A' (bad address)~%" arg0 arg2 arg1)
|
|
)
|
|
#f
|
|
)
|
|
((and (= arg1 type) (!= (rtype-of arg0) type))
|
|
(if arg2
|
|
(format
|
|
arg4
|
|
"ERROR: object #x~X ~S is not a valid object of type '~A' (invalid type #x~X)~%"
|
|
arg0
|
|
arg2
|
|
arg1
|
|
(rtype-of arg0)
|
|
)
|
|
)
|
|
#f
|
|
)
|
|
((and (!= arg1 type) (not (valid? (rtype-of arg0) type #f #t 0)))
|
|
(if arg2
|
|
(format
|
|
arg4
|
|
"ERROR: object #x~X ~S is not a valid object of type '~A' (invalid type #x~X)~%"
|
|
arg0
|
|
arg2
|
|
arg1
|
|
(rtype-of arg0)
|
|
)
|
|
)
|
|
#f
|
|
)
|
|
((not (type? arg0 arg1))
|
|
(if arg2
|
|
(format
|
|
arg4
|
|
"ERROR: object #x~X ~S is not a valid object of type '~A' (is type '~A' instead)~%"
|
|
arg0
|
|
arg2
|
|
arg1
|
|
(rtype-of arg0)
|
|
)
|
|
)
|
|
#f
|
|
)
|
|
((= arg1 symbol)
|
|
(cond
|
|
((>= (the-as uint arg0) (end-of-symbol-table))
|
|
(if arg2
|
|
(format
|
|
arg4
|
|
"ERROR: object #x~X ~S is not a valid object of type '~A' (not in symbol table)~%"
|
|
arg0
|
|
arg2
|
|
arg1
|
|
)
|
|
)
|
|
#f
|
|
)
|
|
(else
|
|
#t
|
|
)
|
|
)
|
|
)
|
|
((< (the-as uint arg0) (end-of-symbol-table))
|
|
(if arg2
|
|
(format
|
|
arg4
|
|
"ERROR: object #x~X ~S is not a valid object of type '~A' (inside symbol table)~%"
|
|
arg0
|
|
arg2
|
|
arg1
|
|
)
|
|
)
|
|
#f
|
|
)
|
|
(else
|
|
#t
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;
|
|
;; 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
|
|
)
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; 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)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; 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)
|
|
)
|