mirror of
https://github.com/open-goal/jak-project.git
synced 2024-10-20 21:27:52 -04:00
6e0ff4c9d0
* fix parent issue * fix compiler issue * update * add error messages * fix error * fix array access, temporary * more clean * fix * rename arg variables better * fix method name * fix no return value in decompiler * many small fixes * cheat types so it works * name map * fix old test'
653 lines
18 KiB
Common Lisp
653 lines
18 KiB
Common Lisp
;;-*-Lisp-*-
|
|
(in-package goal)
|
|
|
|
;; name: gcommon.gc
|
|
;; name in dgo: gcommon
|
|
;; dgos: KERNEL
|
|
|
|
;; gcommon is the first file compiled and loaded.
|
|
;; it's expected that this function will mostly be hand-decompiled
|
|
|
|
(defun identity ((x object))
|
|
"Function which returns its input. The first function of the game!"
|
|
x
|
|
)
|
|
|
|
(defun 1/ ((x float))
|
|
"Reciprocal floating point"
|
|
;; likely inlined? nothing calls this.
|
|
(declare (inline))
|
|
(/ 1. x)
|
|
)
|
|
|
|
;; these next 4 functions are just function wrappers around the build in add/subtract/multiply/divide.
|
|
;; this will let you use + as an operation on integers and also as a function pointer.
|
|
(defun + ((x int) (y int))
|
|
"Compute the sum of two integers"
|
|
(+ x y)
|
|
)
|
|
|
|
(defun - ((x int) (y int))
|
|
"Compute the difference of two integers"
|
|
(- x y)
|
|
)
|
|
|
|
(defun * ((x int) (y int))
|
|
"Compute the product of two integers"
|
|
;; TODO - verify that this matches the PS2 exactly.
|
|
;; Uses mult (three operand form) in MIPS
|
|
(* x y)
|
|
)
|
|
|
|
(defun / ((x int) (y int))
|
|
"Compute the quotient of two integers"
|
|
;; TODO - verify this matches the PS2 exactly
|
|
(/ x y)
|
|
)
|
|
|
|
(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 mod ((a int) (b int))
|
|
"Compute mod. It does what you expect for positive numbers. For negative numbers, nobody knows what to expect.
|
|
This is a 32-bit operation. It uses an idiv on x86 and gets the remainder."
|
|
|
|
;; The original implementation is div, mfhi
|
|
;; todo - verify this is exactly the same as the PS2.
|
|
(mod a b)
|
|
)
|
|
|
|
|
|
(defun rem ((a int) (b int))
|
|
"Compute remainder (32-bit). It is identical to mod. It uses a idiv and gets the remainder"
|
|
|
|
;; The original implementation is div, mfhi
|
|
;; todo - verify this is exactly the same as the PS2.
|
|
(mod a b)
|
|
)
|
|
|
|
(defun abs ((a int))
|
|
"Take the absolute value of an integer"
|
|
|
|
(declare (inline))
|
|
|
|
;; OpenGOAL doesn't support abs, so we implement it here.
|
|
(if (> a 0) ;; condition is "a > 0"
|
|
a ;; true case, return a
|
|
(- a) ;; false case, return -a. (- a) is like (- 0 a)
|
|
)
|
|
)
|
|
|
|
(defun min ((a int) (b int))
|
|
"Compute minimum."
|
|
|
|
;; The original implementation was inline assembly, to take advantage of branch delay slots:
|
|
;; (or v0 a0 r0) ;; move first arg to output (case of second arg being min)
|
|
;; (or v1 a1 r0) ;; move second arg to v1 (likely strange coloring)
|
|
;; (slt a0 v0 v1) ;; compare args
|
|
;; (movz v0 v1 a0) ;; conditional move the second arg to v0 if it's the minimum
|
|
|
|
;; OpenGOAL doesn't support min, so we implement it here.
|
|
(declare (inline))
|
|
(if (> a b) b a)
|
|
)
|
|
|
|
(defun max ((a int) (b int))
|
|
"Compute maximum."
|
|
(declare (inline))
|
|
;; OpenGOAL doesn't support max so we implement it here.
|
|
(if (> a b) a b)
|
|
)
|
|
|
|
(defun logior ((a int) (b int))
|
|
"Compute the bitwise inclusive-or"
|
|
(logior a b)
|
|
)
|
|
|
|
(defun logand ((a int) (b int))
|
|
"Compute the bitwise and"
|
|
(logand a b)
|
|
)
|
|
|
|
(defun lognor ((a int) (b int))
|
|
"Compute not or."
|
|
;; 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 ((a int) (b int))
|
|
"Compute the logical exclusive-or"
|
|
(logxor a b)
|
|
)
|
|
|
|
(defun lognot ((a int))
|
|
"Compute the bitwise not"
|
|
(lognot a)
|
|
)
|
|
|
|
(defun false-func ()
|
|
"Return false"
|
|
'#f
|
|
)
|
|
|
|
(defun true-func ()
|
|
"Return true"
|
|
'#t
|
|
)
|
|
|
|
;; 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)
|
|
|
|
;; vec4s - this is present in the game as a 128-bit integer with 4 packed floats.
|
|
;; 128-bit integers seem to be used almost never in GOAL and I suspect they were not
|
|
;; fully implemented in the compiler. Instead, 128-bit integer code used inline assembly.
|
|
;; OpenGOAL does not support 128-bit integer types, so this is a bit useless.
|
|
;; Note - the actually used vector type stores the vector in memory, not a register.
|
|
;; inline assembly code puts the register in vf registers, not integer registers.
|
|
(deftype vec4s (uint128)
|
|
((x float :offset 0)
|
|
(y float :offset 32)
|
|
(z float :offset 64)
|
|
(w float :offset 96))
|
|
:method-count-assert 9
|
|
:size-assert #x10
|
|
:flag-assert #x900000010
|
|
)
|
|
|
|
;; A "boxed float" type. Simply a float with type information.
|
|
(deftype bfloat (basic)
|
|
((data float :offset-assert 4))
|
|
:size-assert 8
|
|
:method-count-assert 9
|
|
:flag-assert #x900000008
|
|
)
|
|
|
|
(defmethod print bfloat ((obj bfloat))
|
|
"Override the default print method to print a bfloat like a normal float"
|
|
(format #t "~f" (-> obj data))
|
|
obj
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Type System
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defmethod asize-of type ((obj 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.
|
|
(align16 (+ 28 (* 4 (-> type allocated-length))))
|
|
)
|
|
|
|
(defun basic-type? ((obj basic) (input-type type))
|
|
"Is obj an object of type input-type, or of child type of input-type?
|
|
Note: checking if a basic is of type object will return #f."
|
|
(let ((basics-type (-> obj type))
|
|
(object-type object))
|
|
(until (eq? (set! basics-type (-> basics-type parent)) object-type)
|
|
(if (eq? basics-type input-type)
|
|
(return #t)
|
|
)
|
|
)
|
|
)
|
|
#f ;; didn't find it, return false
|
|
)
|
|
|
|
(defun type-type? ((a type) (b type))
|
|
"is a a type (or child type) of type b?"
|
|
(let ((object-type object))
|
|
(until (or (eq? (set! a (-> a parent)) object-type)
|
|
(zero? a)
|
|
)
|
|
(if (eq? a b)
|
|
(return #t)
|
|
)
|
|
)
|
|
)
|
|
#f
|
|
)
|
|
|
|
(defun find-parent-method ((the-type type) (method-id int))
|
|
"Find the nearest parent which has a different method, and get that method.
|
|
Use with extreme caution - if a checked parent has fewer methods than the child, it will
|
|
access out-of-bounds memory. Returns the nothing function if it gets to the top and
|
|
the parent has the same type, or if any parent has 0 as a method."
|
|
(let* ((child-method (-> the-type method-table method-id))
|
|
(parent-method child-method)
|
|
)
|
|
|
|
;; keep looking until we find a different parent method
|
|
(until (not (eq? parent-method child-method))
|
|
;; at the top of the type tree.
|
|
(if (eq? the-type object)
|
|
(return-from #f nothing)
|
|
)
|
|
|
|
(set! the-type (-> the-type parent))
|
|
(set! parent-method (-> the-type method-table method-id))
|
|
(if (eq? 0 (the int parent-method))
|
|
(return-from #f nothing)
|
|
)
|
|
)
|
|
parent-method
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;; pair and list
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun ref ((obj object) (idx int))
|
|
"Get the nth item from a list. No type checking or range checking is done, so be careful!"
|
|
(dotimes (i idx (car obj))
|
|
(set! obj (cdr obj))
|
|
)
|
|
)
|
|
|
|
(defmethod length pair ((obj pair))
|
|
"Get the number of elements in a proper list"
|
|
(if (eq? obj '())
|
|
(return-from #f 0)
|
|
)
|
|
|
|
(let ((lst (cdr obj))
|
|
(len 1))
|
|
(while (and (not (eq? lst '()))
|
|
(pair? lst)
|
|
)
|
|
(+1! len)
|
|
(set! lst (cdr lst))
|
|
)
|
|
len)
|
|
)
|
|
|
|
(defmethod asize-of pair ((obj pair))
|
|
"Get the asize of a pair"
|
|
(the-as int (-> pair size))
|
|
)
|
|
|
|
(defun last ((obj object))
|
|
"Get the last pair in a list."
|
|
(while (not (eq? (cdr obj) '()))
|
|
(set! obj (cdr obj))
|
|
)
|
|
obj
|
|
)
|
|
|
|
(defun member ((obj object) (lst object))
|
|
"if obj is a member of the list, return the pair containing obj as its car.
|
|
if not, return #f."
|
|
(while (and (not (eq? lst '()))
|
|
(not (eq? (car lst) obj)))
|
|
(set! lst (cdr lst))
|
|
)
|
|
|
|
(if (eq? lst '())
|
|
#f
|
|
lst
|
|
)
|
|
)
|
|
|
|
(define-extern name= (function basic basic symbol))
|
|
|
|
(defun nmember ((obj basic) (lst object))
|
|
"If obj is a member of the list, return the pair containing obj as its car.
|
|
If not, return #f. Use name= (see gstring.gc) to check equality."
|
|
(while (and (not (eq? lst '()))
|
|
(not (name= (the basic (car lst)) obj))
|
|
)
|
|
(set! lst (cdr lst))
|
|
)
|
|
|
|
(if (eq? lst '())
|
|
#f
|
|
lst
|
|
)
|
|
)
|
|
|
|
(defun assoc ((item object) (alst object))
|
|
"Get a pair with car of item from the association list (list of pairs) alst."
|
|
(while (and (not (null? alst))
|
|
(not (eq? (caar alst) item)))
|
|
(set! alst (cdr alst))
|
|
)
|
|
(if (not (null? alst))
|
|
(car alst)
|
|
#f
|
|
)
|
|
)
|
|
|
|
(defun assoce ((item object) (alst object))
|
|
"Like assoc, but a pair with car of 'else will match anything"
|
|
(while (and (not (null? alst))
|
|
(not (eq? (caar alst) item))
|
|
(not (eq? (caar alst) 'else))
|
|
)
|
|
(set! alst (cdr alst))
|
|
)
|
|
(if (not (null? alst))
|
|
(car alst)
|
|
#f
|
|
)
|
|
)
|
|
|
|
(defun nassoc ((a0-0 string) (a1-0 object))
|
|
(local-vars
|
|
(v0-2 object)
|
|
(v1-1 object)
|
|
(v1-3 symbol)
|
|
(a1-1 object)
|
|
(s5-0 string)
|
|
(gp-0 object)
|
|
)
|
|
(begin
|
|
(set! s5-0 a0-0)
|
|
(set! gp-0 a1-0)
|
|
(while
|
|
(not
|
|
(or
|
|
(= gp-0 '())
|
|
(begin
|
|
(set! a1-1 (car (car gp-0)))
|
|
(if (pair? a1-1) (nmember s5-0 a1-1) (name= (the basic a1-1) s5-0))
|
|
)
|
|
)
|
|
)
|
|
(set! gp-0 (cdr gp-0))
|
|
)
|
|
(set! v1-3 '#f)
|
|
(if (!= gp-0 '()) (car gp-0))
|
|
)
|
|
)
|
|
|
|
(defun nassoce ((a0-0 string) (a1-0 object))
|
|
(local-vars
|
|
(v0-2 object)
|
|
(v1-1 object)
|
|
(v1-4 symbol)
|
|
(s4-0 object)
|
|
(s5-0 string)
|
|
(gp-0 object)
|
|
)
|
|
(begin
|
|
(set! s5-0 a0-0)
|
|
(set! gp-0 a1-0)
|
|
(while
|
|
(not
|
|
(or
|
|
(= gp-0 '())
|
|
(begin
|
|
(set! s4-0 (car (car gp-0)))
|
|
(if
|
|
(pair? s4-0)
|
|
(nmember s5-0 s4-0)
|
|
(or (name= (the basic s4-0) s5-0) (= s4-0 'else))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(set! gp-0 (cdr gp-0))
|
|
)
|
|
(set! v1-4 '#f)
|
|
(if (!= gp-0 '()) (car gp-0))
|
|
)
|
|
)
|
|
|
|
(defun append! ((front object) (back object))
|
|
"Append back to front."
|
|
(if (null? front)
|
|
(return-from #f back)
|
|
)
|
|
|
|
(let ((lst front))
|
|
;; seek to the end of front
|
|
(while (not (null? (cdr lst)))
|
|
(set! lst (cdr lst))
|
|
)
|
|
|
|
;; this check seems not needed
|
|
(if (not (null? lst))
|
|
(set! (cdr lst) back)
|
|
)
|
|
|
|
front
|
|
)
|
|
)
|
|
|
|
(defun delete! ((item object) (lst object))
|
|
"Delete the first occurance of item from a list and return the list.
|
|
Does nothing if the item isn't in the list."
|
|
(if (eq? (car lst) item)
|
|
(return-from #f (the pair (cdr lst)))
|
|
)
|
|
|
|
(let ((iter (cdr lst))
|
|
(rep lst))
|
|
|
|
(while (and (not (null? iter))
|
|
(not (eq? (car iter) item)))
|
|
(set! rep iter)
|
|
(set! iter (cdr iter))
|
|
)
|
|
|
|
(if (not (null? iter))
|
|
(set! (cdr rep) (cdr iter))
|
|
)
|
|
)
|
|
(the pair lst)
|
|
)
|
|
|
|
(defun delete-car! ((item object) (lst object))
|
|
"Like delete, but will delete if (car item-from-list) is equal to item. Useful for deleting from association list by key."
|
|
;(format #t "call to delete car: ~A ~A~%" item lst)
|
|
(if (eq? (caar lst) item)
|
|
(return-from #f (cdr lst))
|
|
)
|
|
|
|
(let ((rep lst)
|
|
(iter (cdr lst)))
|
|
(while (and (not (null? iter))
|
|
(not (eq? (caar iter) item)))
|
|
(set! rep iter)
|
|
(set! iter (cdr iter))
|
|
)
|
|
|
|
(if (not (null? iter))
|
|
(set! (cdr rep) (cdr iter))
|
|
)
|
|
)
|
|
lst
|
|
)
|
|
|
|
(defun insert-cons! ((kv object) (alst object))
|
|
"Insert key-value pair into an association list. Also removes the old one if it was there."
|
|
(cons kv (delete-car! (car kv) alst))
|
|
)
|
|
|
|
(defun sort ((lst object) (compare (function object object object)))
|
|
"Sort the given list in place. Uses the given comparison function. The comparison function can
|
|
either return #t/#f or an integer, in which case the sign of the integer determines lt/gt."
|
|
;; in each iteration, we count how many changes we make. Once we make no changes, the list is sorted.
|
|
(let ((changes -1))
|
|
|
|
(while (not (zero? changes)) ;; outer loop
|
|
(set! changes 0) ;; reset changes for this iteration
|
|
(let ((iter lst)) ;; iterate through list
|
|
(while (and (not (null? (cdr iter)))
|
|
(pair? (cdr iter)))
|
|
;; L221
|
|
(let* ((val1 (car iter)) ;; value at iterator
|
|
(val2 (car (cdr iter))) ;; value after iterator
|
|
(c-result (compare val1 val2))) ;; run comparison function
|
|
;; check if val1 and val2 are in order. The compare function may either return #t
|
|
;; or it may return val1 - val2. There is an issue if val1 - val2 happens to equal #t or #f.
|
|
(unless (or
|
|
(and c-result (<= (the integer c-result) 0)) ;; not #f, and negative, we're sorted!
|
|
(eq? c-result #t) ;; explictly return #t, we're sorted!
|
|
)
|
|
;; these two aren't sorted! so we swap them and increment changes.
|
|
(+1! changes)
|
|
(set! (car iter) val2)
|
|
(set! (car (cdr iter)) val1)
|
|
)
|
|
;; move on to the next thing in the list.
|
|
(set! iter (cdr iter))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
lst
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;; inline array
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; a parent class for boxed "inline arrays" classes,
|
|
;; An inline-array is an array with a bunch of objects back-to-back, as opposed to a bunch of
|
|
;; references back to back.
|
|
;; Most inline-arrays are unboxed and are just data - this is a somewhat rarely used container parent
|
|
;; class for a class that wraps an unboxed inline-array.
|
|
;; the "heap-base" field of the type is used to store the indexing scale.
|
|
|
|
(deftype inline-array-class (basic)
|
|
((length int32 :offset-assert 4)
|
|
(allocated-length int32 :offset-assert 8)
|
|
(data uint8 :dynamic)
|
|
(_pad uint8 4)
|
|
)
|
|
(:methods (new (symbol type int) _type_ 0) ;; we will override print later on. This is optional to include
|
|
)
|
|
)
|
|
|
|
(defmethod new inline-array-class ((allocation symbol) (type-to-make type) (cnt int))
|
|
"Create a new inline-array. Sets the length, allocated-length to cnt. Uses the mysterious heap-base field
|
|
of the type-to-make to determine the element size"
|
|
(let* ((sz (+ (-> type-to-make size) (* (-> type-to-make heap-base) cnt)))
|
|
(new-object (object-new allocation type-to-make (the int sz))))
|
|
;;(format 0 "create sz ~d at #x~X~%" sz new-object)
|
|
(unless (zero? new-object)
|
|
(set! (-> new-object length) cnt)
|
|
(set! (-> new-object allocated-length) cnt)
|
|
)
|
|
new-object
|
|
)
|
|
)
|
|
|
|
(defmethod length inline-array-class ((obj inline-array-class))
|
|
;"Get the length of an inline-array"
|
|
(-> 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) (-> obj type heap-base))
|
|
)
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; array
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; boxed "pointer like" array.
|
|
;; unlike inline-array-class, all arrays are type array, but the content-type field stores the element type.
|
|
;; the stride of an array is 4, unless the element is a number, in which case the stride is the "size"
|
|
|
|
(defmethod new array ((allocation symbol) (type-to-make type) (content-type type) (size int))
|
|
"Create a new array. The length and allocated-length are both set to size."
|
|
(let ((obj (object-new allocation type-to-make (* size (if (type-type? content-type number)
|
|
(-> content-type size)
|
|
4
|
|
)))))
|
|
(set! (-> obj length) size)
|
|
(set! (-> obj allocated-length) size)
|
|
(set! (-> obj content-type) content-type)
|
|
obj
|
|
)
|
|
)
|
|
|
|
;; todo array print and array inspect
|
|
|
|
(defmethod length array ((obj array))
|
|
"Get the length field of an array."
|
|
(-> obj length)
|
|
)
|
|
|
|
(defmethod asize-of array ((obj array))
|
|
"Get the size in memory of an array."
|
|
(the int (+ (-> array size) (* (-> obj allocated-length)
|
|
(if (type-type? (-> obj content-type) number)
|
|
(-> obj content-type size)
|
|
4))))
|
|
)
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; memcpy and similar
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(defun mem-copy! ((dst pointer) (src pointer) (size int))
|
|
"Copy memory from src to dst. Size is in bytes. This is not an efficient implementation,
|
|
however, there are _no restrictions_ on size, alignment etc. Increasing address copy."
|
|
(let ((i 0)
|
|
(d (the pointer dst))
|
|
(s (the pointer src))
|
|
)
|
|
|
|
(while (< i size)
|
|
(set! (-> (the (pointer uint8) d) 0) (-> (the (pointer uint8) s) 0))
|
|
(&+! d 1)
|
|
(&+! s 1)
|
|
(+1! i)
|
|
)
|
|
)
|
|
dst
|
|
)
|
|
|
|
(defun mem-set32! ((dst pointer) (n int) (value int))
|
|
"Memset a 32-bit value n times. Total memory filled is 4 * n bytes."
|
|
(let ((p (the pointer dst))
|
|
(i 0))
|
|
(while (< i n)
|
|
(set! (-> (the (pointer int32) p) 0) value)
|
|
(&+! p 4)
|
|
(+1! i)
|
|
)
|
|
)
|
|
dst
|
|
)
|
|
|
|
|
|
(defun print-tree-bitmask ((bitmask int) (len int))
|
|
"The purpose of this function is unknown"
|
|
(dotimes (i len #f)
|
|
(if (zero? (logand bitmask 1))
|
|
(format #t " ")
|
|
(format #t "| ")
|
|
)
|
|
(set! bitmask (ash bitmask -1))
|
|
)
|
|
)
|