mirror of
https://github.com/open-goal/jak-project
synced 2026-09-01 09:53:12 -04:00
Parker
de25f39439
Got OpenGOAL building and running natively on Apple Silicon. This is the rest of the port after the smaller arm64 emitter PRs. I was told pushing one big PR was okay. This covers goalc, the runtime, linker, kernel and the GOAL asm. The new paths have native tests. I also found four more emitter bugs while running it. They're in scalar sqrt, 128-bit stores, scalar max and indexed stores above 4 GB. Spent a while cleaning it up so it's easier to read. 4am gotta sleep lol Closes #3841 --------- Co-authored-by: Tyler Wilding <xtvaser@gmail.com>
281 lines
9.2 KiB
Common Lisp
281 lines
9.2 KiB
Common Lisp
|
|
(defun target-function ((a0 uint) (a1 uint) (a2 uint) (a3 uint) (a4 uint) (a5 uint))
|
|
(format #t "TARGET FUNCTION ~D ~D ~D~%" a0 a1 a2)
|
|
(format #t "~D ~D ~D~%" a3 a4 a5)
|
|
|
|
(let ((stack-arr (new 'stack-no-clear 'array 'uint8 12)))
|
|
(format #t "Stack Alignemnt ~D/16~%" (logand 15 (the uint stack-arr)))
|
|
)
|
|
|
|
(dotimes (i 10)
|
|
(format #t "proc1: ~D~%" i)
|
|
(when (> i 4)
|
|
(format #t "DEACTIVATE PROC 1~%")
|
|
(process-deactivate)
|
|
)
|
|
(suspend)
|
|
)
|
|
)
|
|
|
|
(define-extern recurse (function int (pointer int32) int))
|
|
(defun recurse ((i int) (ptr (pointer int32)))
|
|
(if (> i 0)
|
|
(recurse (- i 1) ptr)
|
|
(suspend)
|
|
)
|
|
(set! (-> ptr) (+ (-> ptr) 1))
|
|
1
|
|
)
|
|
|
|
(defun target-function-2 ()
|
|
(let ((stack-var (new 'stack-no-clear 'array 'int32 1)))
|
|
(set! (-> stack-var) 0)
|
|
(countdown (i 10)
|
|
(format #t "proc2: ~D~%" (-> stack-var))
|
|
(recurse 5 stack-var)
|
|
)
|
|
)
|
|
|
|
)
|
|
|
|
(defun kernel-test ()
|
|
(define test-process (get-process *nk-dead-pool* process 1024))
|
|
|
|
(activate test-process *active-pool* 'test-proc *kernel-dram-stack*)
|
|
|
|
|
|
(set-to-run (-> test-process main-thread)
|
|
target-function
|
|
1 2 3 4 5 6
|
|
)
|
|
|
|
(define test-process-2 (get-process *nk-dead-pool* process 1024))
|
|
;; test that the kernel fakes having process stacks on the scratchpad.
|
|
(activate test-process-2 *active-pool* 'test-2 (the pointer #x70004000))
|
|
(set-to-run (-> test-process-2 main-thread)
|
|
target-function-2
|
|
0 0 0 0 0 0)
|
|
0
|
|
)
|
|
|
|
(defun init-child-proc (a0 a1 a2 a3 a4 a5)
|
|
(format #t "Args: ~D ~D ~D~%" a0 a1 a2)
|
|
(format #t "~D ~D ~D~%" a3 a4 a5)
|
|
(let ((stack-arr (new 'stack-no-clear 'array 'uint8 12)))
|
|
(format #t "Stack Alignemnt ~D/16~%" (logand 15 (the uint stack-arr)))
|
|
)
|
|
(if (eq? a0 (the int 0))
|
|
(process-deactivate)
|
|
)
|
|
'init-child-proc-result
|
|
)
|
|
|
|
|
|
(defun initializer-process-function (a0)
|
|
(let ((child-proc (get-process *nk-dead-pool* process 1024)))
|
|
;; let's go
|
|
(activate child-proc *active-pool* 'child-proc *kernel-dram-stack*)
|
|
(let ((result (run-function-in-process child-proc init-child-proc a0 2 3 4 5 6)))
|
|
(format #t "run-function-in-process result: ~A~%" result)
|
|
)
|
|
)
|
|
|
|
(process-deactivate)
|
|
)
|
|
|
|
(defun kernel-test-2 ()
|
|
(define initalizer-process (get-process *nk-dead-pool* process 1024))
|
|
(activate initalizer-process *active-pool* 'initializer-proc *kernel-dram-stack*)
|
|
(set-to-run (-> initalizer-process main-thread)
|
|
initializer-process-function
|
|
0 0 0 0 0 0
|
|
)
|
|
(define initalizer-process-2 (get-process *nk-dead-pool* process 1024))
|
|
(activate initalizer-process-2 *active-pool* 'initializer-proc-2 *kernel-dram-stack*)
|
|
(set-to-run (-> initalizer-process-2 main-thread)
|
|
initializer-process-function
|
|
1 0 0 0 0 0
|
|
)
|
|
0
|
|
)
|
|
|
|
|
|
(defstate die-state (process)
|
|
:enter (lambda () (format #t "enter die~%") (none))
|
|
:exit (lambda () (format #t "exit die~%") (none))
|
|
:code (lambda ()
|
|
(format #t "time to die!~%")
|
|
(process-deactivate)
|
|
(format #t "don't see me~%")
|
|
)
|
|
)
|
|
|
|
(defun arm64-suspend-vector-check ()
|
|
(let ((src (new 'stack-no-clear 'array 'uint64 4))
|
|
(dst (new 'stack-no-clear 'array 'uint64 4)))
|
|
(set! (-> src 0) #x0808080808080808)
|
|
(set! (-> src 1) #x1818181818181818)
|
|
(set! (-> src 2) #x0909090909090909)
|
|
(set! (-> src 3) #x1919191919191919)
|
|
(rlet ((vf :class vf)
|
|
(i128 :class i128 :type uint128))
|
|
(.lvf vf src)
|
|
(set! i128 (-> (the (pointer uint128) src) 1))
|
|
(suspend)
|
|
(.svf dst vf)
|
|
(set! (-> (the (pointer uint128) dst) 1) i128))
|
|
(format #t "suspend vectors #x~16X~16X #x~16X~16X~%"
|
|
(-> dst 1) (-> dst 0) (-> dst 3) (-> dst 2))))
|
|
|
|
(defun xmm-check-code (ax ay az aw)
|
|
"This function relies on saved xmm register being backed up on a context switch"
|
|
;; (declare (print-asm))
|
|
;; compiler will put these in xmm8 and xmm9 to keep them from being clobbered
|
|
(let ((x 12.34)
|
|
(y 45.63))
|
|
(dotimes (i 3)
|
|
(format #t "run xmm-check ~f ~f ~D ~D ~D ~D~%" x y ax ay az aw)
|
|
;; should preserve xmm8 and xmm9
|
|
(suspend)
|
|
)
|
|
(#cond
|
|
((eq? INSTRUCTION_SET 'arm64) (arm64-suspend-vector-check))
|
|
(#t (none)))
|
|
;; get the wreck process and make it go to die state.
|
|
(go-process (process-by-name 'wreck-proc *active-pool*) die-state)
|
|
(go die-state)
|
|
(format #t "unreachable~%")
|
|
)
|
|
)
|
|
|
|
(defun xmm-wreck-code (ax ay az aw)
|
|
"This function intentionally overwrites xmm8 and xmm9 and suspends"
|
|
;; :reg needs a literal, so use the saved register for this backend
|
|
(#cond
|
|
((eq? INSTRUCTION_SET 'arm64)
|
|
(while #t
|
|
(rlet ((x :class fpr :type float :reg v8)
|
|
(y :class fpr :type float :reg v9))
|
|
(set! x 99.0)
|
|
(set! y 101.0)
|
|
(format #t "wreck: ~D ~D ~D ~D~%" ax ay az aw)
|
|
(suspend)
|
|
(set! x (+ x 1.0))
|
|
(set! y (+ y 1.0))
|
|
)
|
|
))
|
|
(#t
|
|
(while #t
|
|
(rlet ((x :class fpr :type float :reg xmm8)
|
|
(y :class fpr :type float :reg xmm9))
|
|
(set! x 99.0)
|
|
(set! y 101.0)
|
|
(format #t "wreck: ~D ~D ~D ~D~%" ax ay az aw)
|
|
(suspend)
|
|
(set! x (+ x 1.0))
|
|
(set! y (+ y 1.0))
|
|
)
|
|
)))
|
|
)
|
|
|
|
;; a state.
|
|
(defstate xmm-check-state (process)
|
|
:enter (lambda (x y z w) (format #t "enter check: ~D ~D ~D ~D~%" x y z w) (none))
|
|
:exit (lambda () (format #t "exit check~%") (none))
|
|
:code xmm-check-code
|
|
)
|
|
|
|
(defstate xmm-wreck-state (process)
|
|
:enter (lambda (x y z w) (format #t "enter wreck: ~D ~D ~D ~D~%" x y z w) (none))
|
|
:exit (lambda () (format #t "exit wreck~%") (none))
|
|
:code xmm-wreck-code
|
|
)
|
|
|
|
(defun state-test ()
|
|
(let ((proc (get-process *nk-dead-pool* process 1024)))
|
|
(activate proc *active-pool* 'check-proc *kernel-dram-stack*)
|
|
(run-now-in-process proc (lambda (x y z w) (go xmm-check-state x y z w))
|
|
9 8 7 6)
|
|
)
|
|
|
|
(let ((proc (get-process *nk-dead-pool* process 1024)))
|
|
(activate proc *active-pool* 'wreck-proc *kernel-dram-stack*)
|
|
(run-next-time-in-process proc (lambda (x y z w) (go xmm-wreck-state x y z w))
|
|
3 4 5 6)
|
|
)
|
|
0
|
|
)
|
|
|
|
(#cond
|
|
((eq? INSTRUCTION_SET 'arm64)
|
|
(defun arm64-throw-vector-check ()
|
|
(let ((src (new 'stack-no-clear 'array 'uint64 4))
|
|
(dst (new 'stack-no-clear 'array 'uint64 4)))
|
|
(set! (-> src 0) #x0808080808080808)
|
|
(set! (-> src 1) #x1818181818181818)
|
|
(set! (-> src 2) #x0909090909090909)
|
|
(set! (-> src 3) #x1919191919191919)
|
|
(rlet ((vf :class vf)
|
|
(i128 :class i128 :type uint128))
|
|
(.lvf vf src)
|
|
(set! i128 (-> (the (pointer uint128) src) 1))
|
|
(let ((proc (get-process *nk-dead-pool* process 1024)))
|
|
(activate proc *active-pool* 'vector-throw *kernel-dram-stack*)
|
|
(run-now-in-process proc
|
|
(lambda ()
|
|
(let ((wreck (new 'stack-no-clear 'array 'uint64 4)))
|
|
(set! (-> wreck 0) #x6060606060606060)
|
|
(set! (-> wreck 1) #x7070707070707070)
|
|
(set! (-> wreck 2) #x6161616161616161)
|
|
(set! (-> wreck 3) #x7171717171717171)
|
|
(rlet ((wreck-vf :reg v8 :class vf)
|
|
(wreck-i128 :reg v9 :class i128 :type uint128))
|
|
(.lvf wreck-vf wreck)
|
|
(set! wreck-i128 (-> (the (pointer uint128) wreck) 1))
|
|
(process-deactivate))))))
|
|
(.svf dst vf)
|
|
(set! (-> (the (pointer uint128) dst) 1) i128))
|
|
(format #t "throw vectors #x~16X~16X #x~16X~16X~%"
|
|
(-> dst 1) (-> dst 0) (-> dst 3) (-> dst 2))))))
|
|
|
|
(defun throw-backup-test ()
|
|
(#cond
|
|
((eq? INSTRUCTION_SET 'arm64)
|
|
(rlet ((x :reg v10 :class fpr :type float))
|
|
(set! x 10.10)
|
|
(let ((proc (get-process *nk-dead-pool* process 1024)))
|
|
(activate proc *active-pool* 'asdf *kernel-dram-stack*)
|
|
(format #t "value now is ~f~%" x)
|
|
(run-now-in-process proc (lambda ()
|
|
(rlet ((x2 :reg v10 :class fpr :type float))
|
|
(set! x2 -1.0)
|
|
)
|
|
;; this will throw back.
|
|
(process-deactivate)
|
|
)
|
|
)
|
|
(format #t "now its ~f~%" x)
|
|
|
|
)
|
|
)
|
|
(arm64-throw-vector-check))
|
|
(#t
|
|
(rlet ((x :reg xmm10 :class fpr :type float))
|
|
(set! x 10.10)
|
|
(let ((proc (get-process *nk-dead-pool* process 1024)))
|
|
(activate proc *active-pool* 'asdf *kernel-dram-stack*)
|
|
(format #t "value now is ~f~%" x)
|
|
(run-now-in-process proc (lambda ()
|
|
(rlet ((x2 :reg xmm10 :class fpr :type float))
|
|
(set! x2 -1.0)
|
|
)
|
|
;; this will throw back.
|
|
(process-deactivate)
|
|
)
|
|
)
|
|
(format #t "now its ~f~%" x)
|
|
|
|
)
|
|
)))
|
|
)
|