mirror of
https://github.com/open-goal/jak-project
synced 2026-08-13 20:25:20 -04:00
water111
4f537d4a71
This sets up the C Kernel for Jak 3, and makes it possible to build and load code built with `goalc --jak3`. There's not too much interesting here, other than they switched to a system where symbol IDs (unique numbers less than 2^14) are generated at compile time, and those get included in the object file itself. This is kind of annoying, since it means all tools that produce a GOAL object file need to work together to assign unique symbol IDs. And since the symbol IDs can't conflict, and are only a number between 0 and 2^14, you can't just hash and hope for no collisions. We work around this by ignoring the IDs and re-assigning our own. I think this is very similar to what the C Kernel did on early builds of Jak 3 which supported loading old format level files, which didn't have the IDs included. As far as I can tell, this shouldn't cause any problems. It defeats all of their fancy tricks to save memory by not storing the symbol string, but we don't care.
1335 lines
34 KiB
Common Lisp
1335 lines
34 KiB
Common Lisp
;;-*-Lisp-*-
|
|
(in-package goal)
|
|
|
|
;; name: gcommon.gc
|
|
;; name in dgo: gcommon
|
|
;; dgos: KERNEL
|
|
|
|
;; DECOMP BEGINS
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; 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))
|
|
|
|
;; enables the with-profiler statements, which send profiling data from
|
|
;; GOAL code to the frame profiler in C++.
|
|
(defglobalconstant PC_PROFILER_ENABLE #t)
|
|
|
|
;; 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)
|
|
)
|
|
)
|
|
|
|
(defmethod print ((this vec4s))
|
|
"Custom print for vec4s that prints the 4 values."
|
|
(format #t "#<vector ~F ~F ~F ~F @ #x~X>"
|
|
(-> this x)
|
|
(-> this y)
|
|
(-> this z)
|
|
(-> this w)
|
|
this)
|
|
this
|
|
)
|
|
|
|
(deftype vector (structure)
|
|
((data float 4)
|
|
(x float :overlay-at (-> data 0))
|
|
(y float :overlay-at (-> data 1))
|
|
(z float :overlay-at (-> data 2))
|
|
(w float :overlay-at (-> data 3))
|
|
(quad uint128 :overlay-at (-> data 0))
|
|
)
|
|
)
|
|
|
|
(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)
|
|
)
|
|
)
|
|
|
|
|
|
(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 value calculated here is wrong."
|
|
(the-as int (logand (the-as uint #xfffffff0) (+ (* (-> this 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
|
|
)
|
|
|
|
(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)
|
|
)
|
|
|
|
(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)
|
|
)
|
|
|
|
(defun ref& ((arg0 object) (arg1 int))
|
|
"Get the pair containing the n-th item in a linked list. No range checking."
|
|
(dotimes (v1-0 arg1)
|
|
(nop!)
|
|
(nop!)
|
|
(set! arg0 (cdr arg0))
|
|
)
|
|
(if (null? arg0)
|
|
#f
|
|
arg0
|
|
)
|
|
)
|
|
|
|
(defmethod length ((this pair))
|
|
(local-vars (v0-0 int))
|
|
(cond
|
|
((null? this)
|
|
(set! v0-0 0)
|
|
)
|
|
(else
|
|
(let ((v1-1 (cdr this)))
|
|
(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 ((this pair))
|
|
(the-as int (-> pair size))
|
|
)
|
|
|
|
(defun last ((arg0 object))
|
|
(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))
|
|
(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))
|
|
(while (not (or (null? arg1) (name= (car arg1) arg0)))
|
|
(set! arg1 (cdr arg1))
|
|
)
|
|
(if (not (null? arg1))
|
|
arg1
|
|
)
|
|
)
|
|
|
|
(defun assoc ((arg0 object) (arg1 object))
|
|
(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))
|
|
(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))
|
|
(while (not (or (null? arg1) (let ((a1-1 (car (car arg1))))
|
|
(if (pair? a1-1)
|
|
(nmember arg0 a1-1)
|
|
(name= a1-1 arg0)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(set! arg1 (cdr arg1))
|
|
)
|
|
(if (not (null? arg1))
|
|
(car arg1)
|
|
)
|
|
)
|
|
|
|
(defun nassoce ((arg0 string) (arg1 object))
|
|
(while (not (or (null? arg1) (let ((s4-0 (car (car arg1))))
|
|
(if (pair? s4-0)
|
|
(nmember arg0 s4-0)
|
|
(or (name= s4-0 arg0) (= s4-0 'else))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(set! arg1 (cdr arg1))
|
|
)
|
|
(if (not (null? arg1))
|
|
(car arg1)
|
|
)
|
|
)
|
|
|
|
(defun append! ((arg0 object) (arg1 object))
|
|
(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))
|
|
(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))
|
|
(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))
|
|
(let ((a3-0 (delete-car! (car arg0) arg1)))
|
|
(cons arg0 a3-0)
|
|
)
|
|
)
|
|
|
|
(defun sort ((arg0 pair) (arg1 (function object object object)))
|
|
(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
|
|
)
|
|
|
|
(defun string->symbol-debug ((arg0 string))
|
|
(let ((gp-0 *kernel-symbol-warnings*))
|
|
(set! *kernel-symbol-warnings* #f)
|
|
(let ((v0-0 (string->symbol arg0)))
|
|
(set! *kernel-symbol-warnings* gp-0)
|
|
v0-0
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun symbol->string-debug ((arg0 symbol))
|
|
(let ((gp-0 *kernel-symbol-warnings*))
|
|
(set! *kernel-symbol-warnings* #f)
|
|
(let ((v0-0 (symbol->string arg0)))
|
|
(set! *kernel-symbol-warnings* gp-0)
|
|
v0-0
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun symbol->hash ((arg0 symbol))
|
|
(the-as pointer arg0)
|
|
)
|
|
|
|
(defmethod new array ((allocation symbol) (type-to-make type) (arg0 type) (arg1 int))
|
|
(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 ((this array))
|
|
(format #t "#(")
|
|
(cond
|
|
((type-type? (-> this content-type) integer)
|
|
(case (-> this content-type symbol)
|
|
(('int32)
|
|
(dotimes (s5-0 (-> this length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-0)
|
|
"~D"
|
|
" ~D"
|
|
)
|
|
(-> (the-as (array int32) this) s5-0)
|
|
)
|
|
)
|
|
)
|
|
(('uint32)
|
|
(dotimes (s5-1 (-> this length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-1)
|
|
"~D"
|
|
" ~D"
|
|
)
|
|
(-> (the-as (array uint32) this) s5-1)
|
|
)
|
|
)
|
|
)
|
|
(('int64)
|
|
(dotimes (s5-2 (-> this length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-2)
|
|
"~D"
|
|
" ~D"
|
|
)
|
|
(-> (the-as (array int64) this) s5-2)
|
|
)
|
|
)
|
|
)
|
|
(('uint64)
|
|
(dotimes (s5-3 (-> this length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-3)
|
|
"#x~X"
|
|
" #x~X"
|
|
)
|
|
(-> (the-as (array uint64) this) s5-3)
|
|
)
|
|
)
|
|
)
|
|
(('int8)
|
|
(dotimes (s5-4 (-> this length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-4)
|
|
"~D"
|
|
" ~D"
|
|
)
|
|
(-> (the-as (array int8) this) s5-4)
|
|
)
|
|
)
|
|
)
|
|
(('uint8)
|
|
(dotimes (s5-5 (-> this length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-5)
|
|
"~D"
|
|
" ~D"
|
|
)
|
|
(-> (the-as (array uint8) this) s5-5)
|
|
)
|
|
)
|
|
)
|
|
(('int16)
|
|
(dotimes (s5-6 (-> this length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-6)
|
|
"~D"
|
|
" ~D"
|
|
)
|
|
(-> (the-as (array int16) this) s5-6)
|
|
)
|
|
)
|
|
)
|
|
(('uint16)
|
|
(dotimes (s5-7 (-> this length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-7)
|
|
"~D"
|
|
" ~D"
|
|
)
|
|
(-> (the-as (array uint16) this) s5-7)
|
|
)
|
|
)
|
|
)
|
|
(('uint128 'int128)
|
|
(dotimes (s5-8 (-> this length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-8)
|
|
"#x~X"
|
|
" #x~X"
|
|
)
|
|
(-> (the-as (array uint128) this) s5-8)
|
|
)
|
|
)
|
|
)
|
|
(else
|
|
(dotimes (s5-9 (-> this length))
|
|
(format
|
|
#t
|
|
(if (zero? s5-9)
|
|
"~D"
|
|
" ~D"
|
|
)
|
|
(-> (the-as (array int32) this) s5-9)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
((= (-> this content-type) float)
|
|
(dotimes (s5-10 (-> this length))
|
|
(if (zero? s5-10)
|
|
(format #t "~f" (-> (the-as (array float) this) s5-10))
|
|
(format #t " ~f" (-> (the-as (array float) this) s5-10))
|
|
)
|
|
)
|
|
)
|
|
(else
|
|
(dotimes (s5-11 (-> this length))
|
|
(if (zero? s5-11)
|
|
(format #t "~A" (-> (the-as (array basic) this) s5-11))
|
|
(format #t " ~A" (-> (the-as (array basic) this) s5-11))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(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
|
|
((and (= (logand (the-as int (-> this content-type)) 7) 4) (type-type? (-> this content-type) integer))
|
|
(case (-> this content-type symbol)
|
|
(('int32)
|
|
(dotimes (s5-0 (-> this length))
|
|
(format #t "~T [~D] ~D~%" s5-0 (-> (the-as (array int32) this) s5-0))
|
|
)
|
|
)
|
|
(('uint32)
|
|
(dotimes (s5-1 (-> this length))
|
|
(format #t "~T [~D] ~D~%" s5-1 (-> (the-as (array uint32) this) s5-1))
|
|
)
|
|
)
|
|
(('int64)
|
|
(dotimes (s5-2 (-> this length))
|
|
(format #t "~T [~D] ~D~%" s5-2 (-> (the-as (array int64) this) s5-2))
|
|
)
|
|
)
|
|
(('uint64)
|
|
(dotimes (s5-3 (-> this length))
|
|
(format #t "~T [~D] #x~X~%" s5-3 (-> (the-as (array uint64) this) s5-3))
|
|
)
|
|
)
|
|
(('int8)
|
|
(dotimes (s5-4 (-> this length))
|
|
(format #t "~T [~D] ~D~%" s5-4 (-> (the-as (array int8) this) s5-4))
|
|
)
|
|
)
|
|
(('uint8)
|
|
(dotimes (s5-5 (-> this length))
|
|
(format #t "~T [~D] ~D~%" s5-5 (-> (the-as (array int8) this) s5-5))
|
|
)
|
|
)
|
|
(('int16)
|
|
(dotimes (s5-6 (-> this length))
|
|
(format #t "~T [~D] ~D~%" s5-6 (-> (the-as (array int16) this) s5-6))
|
|
)
|
|
)
|
|
(('uint16)
|
|
(dotimes (s5-7 (-> this length))
|
|
(format #t "~T [~D] ~D~%" s5-7 (-> (the-as (array uint16) this) s5-7))
|
|
)
|
|
)
|
|
(('int128 'uint128)
|
|
(dotimes (s5-8 (-> this length))
|
|
(format #t "~T [~D] #x~X~%" s5-8 (-> (the-as (array uint128) this) s5-8))
|
|
)
|
|
)
|
|
(else
|
|
(dotimes (s5-9 (-> this length))
|
|
(format #t "~T [~D] ~D~%" s5-9 (-> (the-as (array int32) this) s5-9))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
((= (-> this content-type) float)
|
|
(dotimes (s5-10 (-> this length))
|
|
(format #t "~T [~D] ~f~%" s5-10 (-> (the-as (array float) this) s5-10))
|
|
)
|
|
)
|
|
(else
|
|
(dotimes (s5-11 (-> this length))
|
|
(format #t "~T [~D] ~A~%" s5-11 (-> (the-as (array basic) this) s5-11))
|
|
)
|
|
)
|
|
)
|
|
this
|
|
)
|
|
|
|
(defmethod length ((this array))
|
|
(-> this length)
|
|
)
|
|
|
|
(defmethod asize-of ((this array))
|
|
(the-as
|
|
int
|
|
(+ (-> this type size) (* (-> this allocated-length) (if (type-type? (-> this content-type) number)
|
|
(the-as int (-> this content-type size))
|
|
4
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun mem-copy! ((arg0 pointer) (arg1 pointer) (arg2 int))
|
|
(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))
|
|
(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))
|
|
(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 qmem-clear! ((arg0 pointer) (arg1 int))
|
|
(let ((v0-0 arg0))
|
|
(dotimes (v1-0 arg1)
|
|
(set! (-> (the-as (pointer int128) arg0)) (the int128 0))
|
|
(&+! arg0 16)
|
|
)
|
|
v0-0
|
|
)
|
|
)
|
|
|
|
(defun mem-set32! ((arg0 pointer) (arg1 int) (arg2 int))
|
|
(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))
|
|
(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)
|
|
)
|
|
|
|
(deftype inline-array-class (basic)
|
|
((length int32)
|
|
(allocated-length int32)
|
|
(_data uint8 :dynamic :offset 16)
|
|
)
|
|
(:methods
|
|
(new (symbol type int) _type_)
|
|
(push-back (_type_ object) int)
|
|
(inline-array-class-method-10 () none)
|
|
(clear-1 (_type_) symbol)
|
|
(clear-2 (_type_) none)
|
|
(pop-front (_type_ int) pointer)
|
|
)
|
|
)
|
|
|
|
;; these specicializations exist so the push-back and pop-front methods can be hard-coded to have
|
|
;; a fixed sized store/load, rather than mem-cpy the size of the element.
|
|
;; This is kinda like a manual version of C++ templates (and perhaps was a attempt to use GOOS macros to do
|
|
;; something similar? or they just copy-pasted it, idk)
|
|
(deftype inline-array-class-uint64 (inline-array-class)
|
|
((data uint64 :dynamic :offset 16)
|
|
)
|
|
)
|
|
|
|
(deftype inline-array-class-uint32 (inline-array-class)
|
|
((data uint32 :dynamic :offset 16)
|
|
)
|
|
)
|
|
|
|
(defmethod new inline-array-class ((allocation symbol) (type-to-make type) (arg0 int))
|
|
(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 ((this inline-array-class))
|
|
(-> this length)
|
|
)
|
|
|
|
(defmethod asize-of ((this inline-array-class))
|
|
(the-as int (+ (-> this type size) (* (-> this allocated-length) (the-as int (-> this type heap-base)))))
|
|
)
|
|
|
|
(defmethod push-back ((this inline-array-class) (arg0 object))
|
|
(let ((s5-0 (-> this length)))
|
|
(let ((a2-0 (-> this type heap-base)))
|
|
(mem-copy!
|
|
(the-as
|
|
pointer
|
|
(+ (+ (* s5-0 (the-as int (-> this type heap-base))) -4 (-> this type size)) (the-as int this))
|
|
)
|
|
(the-as pointer arg0)
|
|
(the-as int a2-0)
|
|
)
|
|
)
|
|
(+! (-> this length) 1)
|
|
s5-0
|
|
)
|
|
)
|
|
|
|
(defmethod push-back ((this inline-array-class-uint32) (arg0 object))
|
|
(let ((v0-0 (-> this length)))
|
|
(-> this type heap-base)
|
|
(set! (-> (the-as
|
|
(pointer int32)
|
|
(+ (+ (* v0-0 (the-as int (-> this type heap-base))) -4 (-> this type size)) (the-as int this))
|
|
)
|
|
)
|
|
(the-as int32 arg0)
|
|
)
|
|
(+! (-> this length) 1)
|
|
v0-0
|
|
)
|
|
)
|
|
|
|
(defmethod push-back ((this inline-array-class-uint64) (arg0 object))
|
|
(let ((v0-0 (-> this length)))
|
|
(-> this type heap-base)
|
|
(set! (-> (the-as
|
|
(pointer int64)
|
|
(+ (+ (* v0-0 (the-as int (-> this type heap-base))) -4 (-> this type size)) (the-as int this))
|
|
)
|
|
)
|
|
(the-as int64 arg0)
|
|
)
|
|
(+! (-> this length) 1)
|
|
v0-0
|
|
)
|
|
)
|
|
|
|
(defmethod pop-front ((this inline-array-class) (arg0 int))
|
|
(+! (-> this length) -1)
|
|
(+ (-> this length) -1)
|
|
(let ((a2-0 (-> this type heap-base))
|
|
(t9-0 mem-copy!)
|
|
(v1-10 (+ (+ (* (the-as uint arg0) (-> this type heap-base)) -4 (-> this type size)) (the-as uint this)))
|
|
(a1-4 (-> this type heap-base))
|
|
)
|
|
(t9-0
|
|
(the-as pointer v1-10)
|
|
(the-as pointer (+ (+ (* (-> this length) (the-as int a1-4)) -4 (-> this type size)) (the-as int this)))
|
|
(the-as int a2-0)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defmethod pop-front ((this inline-array-class-uint64) (arg0 int))
|
|
(+! (-> this length) -1)
|
|
(+ (-> this length) -1)
|
|
(-> this type heap-base)
|
|
(let* ((v1-7 (-> this type heap-base))
|
|
(v0-0 (-> (the-as
|
|
(pointer uint64)
|
|
(+ (+ (* (-> this length) (the-as int v1-7)) -4 (-> this type size)) (the-as int this))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(set! (-> (the-as
|
|
(pointer uint64)
|
|
(+ (+ (* (the-as uint arg0) (-> this type heap-base)) -4 (-> this type size)) (the-as uint this))
|
|
)
|
|
)
|
|
v0-0
|
|
)
|
|
(the-as pointer v0-0)
|
|
)
|
|
)
|
|
|
|
(defmethod pop-front ((this inline-array-class-uint32) (arg0 int))
|
|
(+! (-> this length) -1)
|
|
(+ (-> this length) -1)
|
|
(-> this type heap-base)
|
|
(let* ((v1-7 (-> this type heap-base))
|
|
(v0-0 (-> (the-as
|
|
(pointer uint32)
|
|
(+ (+ (* (-> this length) (the-as int v1-7)) -4 (-> this type size)) (the-as int this))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(set! (-> (the-as
|
|
(pointer uint32)
|
|
(+ (+ (* (the-as uint arg0) (-> this type heap-base)) -4 (-> this type size)) (the-as uint this))
|
|
)
|
|
)
|
|
v0-0
|
|
)
|
|
(the-as pointer v0-0)
|
|
)
|
|
)
|
|
|
|
(defmethod clear-2 ((this inline-array-class))
|
|
(set! (-> this length) 0)
|
|
0
|
|
(none)
|
|
)
|
|
|
|
(defmethod clear-1 ((this inline-array-class))
|
|
(set! (-> this length) 0)
|
|
#t
|
|
)
|
|
|
|
(defun-recursive fact int ((arg0 int))
|
|
(if (= arg0 1)
|
|
1
|
|
(* arg0 (fact (+ arg0 -1)))
|
|
)
|
|
)
|
|
|
|
(define *print-column* (the-as binteger 0))
|
|
|
|
(defun print ((arg0 object))
|
|
((method-of-type (rtype-of arg0) print) arg0)
|
|
)
|
|
|
|
(defun printl ((arg0 object))
|
|
(let ((a0-1 arg0))
|
|
((method-of-type (rtype-of a0-1) print) a0-1)
|
|
)
|
|
(format #t "~%")
|
|
arg0
|
|
)
|
|
|
|
(defun inspect ((arg0 object))
|
|
((method-of-type (rtype-of arg0) inspect) arg0)
|
|
)
|
|
|
|
(defun-debug mem-print ((arg0 (pointer uint32)) (arg1 int))
|
|
(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
|
|
)
|
|
|
|
(define *trace-list* '())
|
|
|
|
(defun print-tree-bitmask ((arg0 int) (arg1 int))
|
|
(dotimes (s4-0 arg1)
|
|
(if (not (logtest? 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!)
|
|
)
|
|
|
|
#|
|
|
(defun valid? ((arg0 object) (arg1 type) (arg2 string) (arg3 symbol) (arg4 object))
|
|
(local-vars (v1-11 int) (v1-26 int) (v1-56 int) (v1-60 int) (s7-0 none))
|
|
(let ((v1-1
|
|
(and (>= (the-as uint arg0) (the-as uint __START-OF-TABLE__)) (< (the-as uint arg0) (the-as uint #x8000000)))
|
|
)
|
|
)
|
|
(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) (begin
|
|
(let ((v1-10 #x8000))
|
|
(.daddu v1-11 v1-10 s7-0)
|
|
)
|
|
(< (the-as uint arg0) (the-as uint v1-11))
|
|
)
|
|
)
|
|
(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
|
|
((not (logtest? (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
|
|
((not (logtest? (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) (the-as int __START-OF-TABLE__)) (begin
|
|
(let ((v1-25 #x8000))
|
|
(.daddu v1-26 v1-25 s7-0)
|
|
)
|
|
(>= (the-as int arg0) v1-26)
|
|
)
|
|
)
|
|
(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 (the-as string #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)
|
|
(let ((v1-55 #x8000))
|
|
(.daddu v1-56 v1-55 s7-0)
|
|
)
|
|
(cond
|
|
((>= (the-as uint arg0) (the-as uint v1-56))
|
|
(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
|
|
)
|
|
)
|
|
)
|
|
((begin
|
|
(let ((v1-59 #x8000))
|
|
(.daddu v1-60 v1-59 s7-0)
|
|
)
|
|
(< (the-as uint arg0) (the-as uint v1-60))
|
|
)
|
|
(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
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|#
|