mirror/jak-project
1
0
Fork 0
mirror of https://github.com/open-goal/jak-project synced 2026-07-07 22:22:21 -04:00
Code Issues Packages Projects Releases Wiki Activity

[jak3] Decomp for gkernel, gkernel-h, gstate, gstring (#3326)

Browse Source 
I ported the kernel test from jak1/jak2 to jak 3, and it's passing!
This commit is contained in:
water111
2024-01-21 18:08:05 -05:00
committed by GitHub
parent 638bf1d3d9
commit 01d5fc2bbb
27 changed files with 8868 additions and 387 deletions
Download Patch File Download Diff File Expand all files Collapse all files
decompiler/config/jak3/all-types.gc
+316 -246
View File
@@ -546,16 +546,15 @@
:flag-assert #xe00000024
:no-runtime-type
(:methods
(new (symbol type string) _type_)
(activate (_type_ process-tree basic pointer) process-tree)
(deactivate (_type_) none)
(init-from-entity! (_type_ entity-actor) none)
(run-logic? (_type_) symbol)
(process-tree-method-13 () none) ;; 13 ;; (process-tree-method-13 () none 13)
(new "Allocate a process-tree with the kernel clock." (symbol type string) _type_) ;; 0
(activate "Move a process from dead to active, moving it to the given tree." (_type_ process-tree string pointer) process-tree) ;; 9
(deactivate "Make a process dead, clean it up, remove it from the active pool, and return to dead pool." (_type_) none) ;; 10
(init-from-entity! (_type_ entity-actor) none) ;; 11
(run-logic? "Should this process be run? Checked by execute-process-tree." (_type_) symbol) ;; 12
(process-tree-method-13 () none) ;; 13
)
)
#|
(deftype kernel-context (basic)
((prevent-from-run process-mask :offset-assert 4) ;; guessed by decompiler
(require-for-run process-mask :offset-assert 8) ;; guessed by decompiler
@@ -578,7 +577,6 @@
:flag-assert #x900000040
;; field relocating-level uses ~A with a signed load.
)
|#
(deftype time-frame (int64)
()
@@ -604,52 +602,61 @@
:size-assert #x5c
:flag-assert #x180000005c
(:methods
(new (symbol type int) _type_)
(update-rates! (_type_ float) float)
(new (symbol type int) _type_) ;; 0
(update-rates! (_type_ float) float) ;; 9
(clock-method-10 () none) ;; 10 ;; (advance-by! (_type_ float) clock 10)
(clock-method-11 () none) ;; 11 ;; (tick! (_type_) clock 11)
(clock-method-12 () none) ;; 12 ;; (save! (_type_ (pointer uint64)) int 12)
(clock-method-13 () none) ;; 13 ;; (load! (_type_ (pointer uint64)) int 13)
(clock-method-14 () none) ;; 14 ;; (reset! (_type_) none 14)
(clock-method-15 () none) ;; 15
(frame-mask-2 (_type_ int) symbol)
(frame-mask-4 (_type_ int) symbol)
(frame-mask-8 (_type_ int) symbol)
(frame-mask-16 (_type_ int) symbol)
(frame-mask-32 (_type_ int) symbol)
(frame-mask-64 (_type_ int) symbol)
(frame-mask-128 (_type_ int) symbol)
(frame-mask-256 (_type_ int) symbol)
(frame-mask-2 "Check if the frame count, xored with `xor-val` has its lowest bit set" (_type_ int) symbol) ;; 16
(frame-mask-4 "Check if the frame count, xored with `xor-val` has any of its lowest 2 bits set" (_type_ int) symbol) ;; 17
(frame-mask-8 "Check if the frame count, xored with `xor-val` has any of its lowest 3 bits set" (_type_ int) symbol) ;; 18
(frame-mask-16 "Check if the frame count, xored with `xor-val` has any of its lowest 4 bits set" (_type_ int) symbol) ;; 19
(frame-mask-32 "Check if the frame count, xored with `xor-val` has any of its lowest 5 bits set" (_type_ int) symbol) ;; 20
(frame-mask-64 "Check if the frame count, xored with `xor-val` has any of its lowest 6 bits set" (_type_ int) symbol) ;; 21
(frame-mask-128 "Check if the frame count, xored with `xor-val` has any of its lowest 7 bits set" (_type_ int) symbol) ;; 22
(frame-mask-256 "Check if the frame count, xored with `xor-val` has any of its lowest 8 bits set" (_type_ int) symbol) ;; 23
)
)
#|
(deftype thread (basic)
()
((name symbol :offset-assert 4)
(process process :offset-assert 8)
(previous thread :offset-assert 12)
(suspend-hook (function cpu-thread none) :offset-assert 16)
(resume-hook (function cpu-thread none) :offset-assert 20)
(pc pointer :offset-assert 24)
(sp pointer :offset-assert 28)
(stack-top pointer :offset-assert 32)
(stack-size int32 :offset-assert 36)
)
:method-count-assert 12
:size-assert #x28
:flag-assert #xc00000028
;; Failed to read fields.
(:methods
(thread-method-9 () none) ;; 9 ;; (stack-size-set! (_type_ int) none 9)
(thread-method-10 () none) ;; 10 ;; (thread-suspend (_type_) none 10)
(thread-method-11 () none) ;; 11 ;; (thread-resume (_type_) none 11)
(stack-size-set! "Adjust the size of the stack that can be stored during a suspend. Must be called before any process allocations." (_type_ int) none) ;; 9
(thread-suspend "Suspend this thread and jump to the kernel (for use by the kernel only)" (_type_) none) ;; 10
(thread-resume "Jump from the kernel to the restored thread. (for use by the kernel only)" (_type_) none) ;; 11
)
)
|#
#|
(deftype cpu-thread (thread)
()
;; registers modified for PC port.
((rreg uint64 7)
(freg float 8)
(stack uint8 :dynamic)
)
:method-count-assert 12
:size-assert #x80
:flag-assert #xc00000080
;; Failed to read fields.
(:methods
;; (new (symbol type process symbol int pointer) _type_ 0)
(new "Allocate a thread. If there is already a top-thread for this process, assume this is a temporary thread, and allocate on the bottom of the stack." (symbol type process symbol int pointer) _type_) ;; 0
)
)
|#
(deftype dead-pool (process-tree)
()
@@ -657,59 +664,56 @@
:size-assert #x24
:flag-assert #x1000000024
(:methods
;; (new (symbol type int int string) _type_ 0)
(dead-pool-method-14 () none) ;; 14 ;; (get-process (_type_ type int) process 14)
(dead-pool-method-15 () none) ;; 15 ;; (return-process (_type_ process) none 15)
(new "Allocate a dead pool and set up dead processes" (symbol type int int string) _type_) ;; 0
(get-process "Allocate a process from the pool, or #f if it fails." (_type_ type int object) process) ;; 14
(return-process "Return a process to the pool." (_type_ process) none) ;; 15
)
)
#|
(deftype dead-pool-heap-rec (structure)
((process process :offset-assert 0) ;; guessed by decompiler
(prev dead-pool-heap-rec :offset-assert 4)
(next dead-pool-heap-rec :offset-assert 8)
)
:pack-me
:method-count-assert 9
:size-assert #xc
:flag-assert #x90000000c
)
|#
#|
(deftype dead-pool-heap (dead-pool)
((allocated-length int32 :offset-assert 32)
(compact-time uint32 :offset-assert 36)
(compact-count-targ uint32 :offset-assert 40)
(compact-count uint32 :offset-assert 44)
(fill-percent float :offset-assert 48)
(first-gap dead-pool-heap-rec :offset-assert 52)
(first-shrink dead-pool-heap-rec :offset-assert 56)
(heap kheap :inline :offset-assert 60)
(alive-list dead-pool-heap-rec :inline :offset-assert 76)
(last dead-pool-heap-rec :offset-assert 80)
(dead-list dead-pool-heap-rec :inline :offset-assert 88)
(process-list dead-pool-heap-rec :dynamic :offset-assert 100) ;; guessed by decompiler
((allocated-length int32 :offset-assert 36)
(compact-time uint32 :offset-assert 40)
(compact-count-targ uint32 :offset-assert 44)
(compact-count uint32 :offset-assert 48)
(fill-percent float :offset-assert 52)
(first-gap dead-pool-heap-rec :offset-assert 56)
(first-shrink dead-pool-heap-rec :offset-assert 60)
(heap kheap :inline :offset-assert 64)
(alive-list dead-pool-heap-rec :inline :offset-assert 80)
(last dead-pool-heap-rec :offset-assert 84 :overlay-at (-> alive-list prev))
(dead-list dead-pool-heap-rec :inline :offset-assert 92)
(process-list dead-pool-heap-rec :dynamic :inline :offset-assert 104) ;; guessed by decompiler
)
:method-count-assert 28
:size-assert #x68
:flag-assert #x1c00000068
(:methods
;; (new (symbol type string int int) _type_ 0)
(dead-pool-heap-method-16 () none) ;; 16 ;; (init (_type_ symbol int) none 16)
(dead-pool-heap-method-17 () none) ;; 17 ;; (compact (dead-pool-heap int) none 17)
(dead-pool-heap-method-18 () none) ;; 18 ;; (shrink-heap (dead-pool-heap process) dead-pool-heap 18)
(dead-pool-heap-method-19 () none) ;; 19 ;; (churn (dead-pool-heap int) none 19)
(dead-pool-heap-method-20 () none) ;; 20 ;; (memory-used (_type_) int 20)
(dead-pool-heap-method-21 () none) ;; 21 ;; (memory-total (_type_) int 21)
(dead-pool-heap-method-22 () none) ;; 22 ;; (memory-free (dead-pool-heap) int 22)
(dead-pool-heap-method-23 () none) ;; 23 ;; (compact-time (dead-pool-heap) uint 23)
(dead-pool-heap-method-24 () none) ;; 24 ;; (gap-size (dead-pool-heap dead-pool-heap-rec) int 24)
(dead-pool-heap-method-25 () none) ;; 25 ;; (gap-location (dead-pool-heap dead-pool-heap-rec) pointer 25)
(dead-pool-heap-method-26 () none) ;; 26 ;; (find-gap (dead-pool-heap dead-pool-heap-rec) dead-pool-heap-rec 26)
(dead-pool-heap-method-27 () none) ;; 27 ;; (find-gap-by-size (dead-pool-heap int) dead-pool-heap-rec 27)
(new "Allocate and initialize a dead-pool-heap." (symbol type string int int) _type_) ;; 0
(init "Allocate memory for processes and init records." (_type_ symbol int) none) ;; 16
(compact "Relocate process in memory to remove gaps, increasing free memory for this dead-pool-heap." (dead-pool-heap int) none) ;; 17
(shrink-heap "Shrink the heap of a process, allowing the dead pool heap to later reclaim the memory during a compact." (dead-pool-heap process) dead-pool-heap) ;; 18
(churn "Relocate process in memory, to trigger memory bugs related to process relocation." (dead-pool-heap int) none) ;; 19
(memory-used "Get the total memory used. Memory in between processes that is not used by a process is considered used." (_type_) int) ;; 20
(memory-total "Get the total size of the heap for processes." (_type_) int) ;; 21
(memory-free "Get the size of the unused part of the heap." (dead-pool-heap) int) ;; 22
(compact-time "Get the compaction time (never set)." (dead-pool-heap) uint) ;; 23
(gap-size "Get the size of the gap (possibly zero) after the given process. Use #f for the gap at the start of the pool memory." (dead-pool-heap dead-pool-heap-rec) int) ;; 24
(gap-location "Get pointer to gap (possibly zero size) after the given process" (dead-pool-heap dead-pool-heap-rec) pointer) ;; 25
(find-gap "Find the first process with a nonzero gap after it, after the given process." (dead-pool-heap dead-pool-heap-rec) dead-pool-heap-rec) ;; 26
(find-gap-by-size "Find the first gap with a size at least this big" (dead-pool-heap int) dead-pool-heap-rec) ;; 27
)
)
|#
(deftype stack-frame (basic)
((name symbol :offset 4)
@@ -720,61 +724,71 @@
:flag-assert #x90000000c
)
#|
(deftype catch-frame (stack-frame)
()
((sp int32)
(ra int32)
; (freg float 6)
; (rreg uint128 8)
;; In OpenGOAL, we swap a rreg for 4 more fregs.
(freg float 10) ;; only use 8
(rreg uint128 7) ;; only use 5
)
:method-count-assert 9
:size-assert #xb0
:flag-assert #x9000000b0
;; Failed to read fields.
(:methods
(new (symbol type symbol function (pointer uint64)) object) ;; 0
)
)
|#
#|
(deftype protect-frame (stack-frame)
()
((exit (function object))
)
:method-count-assert 9
:size-assert #x10
:flag-assert #x900000010
;; Failed to read fields.
(:methods
(new "Allocate and set up a protect-frame. This _must_ be used on the stack." (symbol type (function object)) protect-frame) ;; 0
)
)
|#
#|
(deftype handle (uint64)
((UNKNOWN UNKNOWN :offset-assert -1) ;; field could not be read.
(UNKNOWN UNKNOWN :offset-assert -1) ;; field could not be read.
((process (pointer process) :offset 0 :size 32) ;; additional level of indirection to support moving processes
(pid int32 :offset 32 :size 32) ;; unique pid to check if it's the same process or not.
(u64 uint64 :offset 0 :size 64)
)
:method-count-assert 9
:size-assert #x8
:flag-assert #x900000008
)
|#
#|
(deftype state (protect-frame)
((name symbol :offset-assert 4) ;; guessed by decompiler
(next stack-frame :offset-assert 8) ;; guessed by decompiler
(exit (function object) :offset-assert 12) ;; guessed by decompiler
(parent basic :offset-assert 16)
((parent state :offset-assert 16)
(code function :offset-assert 20) ;; guessed by decompiler
(trans (function object) :offset-assert 24) ;; guessed by decompiler
(post function :offset-assert 28) ;; guessed by decompiler
(enter function :offset-assert 32) ;; guessed by decompiler
(event (function process int symbol event-message-block object) :offset-assert 36) ;; guessed by decompiler
)
(:methods
(new (symbol type symbol function
(function object)
function
(function object)
(function process int symbol event-message-block object)) _type_) ;; 0
)
:method-count-assert 9
:size-assert #x28
:flag-assert #x900000028
)
|#
#|
(deftype event-message-block (structure)
((to-handle uint64 :offset-assert 0) ;; handle
(to (pointer process) :offset-assert 0) ;; guessed by decompiler
(from-handle uint64 :offset-assert 8)
(from (pointer process) :offset-assert 8) ;; guessed by decompiler
((to-handle handle :offset-assert 0)
(to (pointer process) :offset-assert 0 :overlay-at to-handle) ;; guessed by decompiler
(from-handle handle :offset-assert 8)
(from (pointer process) :offset-assert 8 :overlay-at from-handle)
(param uint64 6 :offset-assert 16) ;; guessed by decompiler
(message symbol :offset-assert 64) ;; guessed by decompiler
(num-params int32 :offset-assert 68)
@@ -783,20 +797,20 @@
:size-assert #x48
:flag-assert #x900000048
)
|#
#|
(deftype event-message-block-array (inline-array-class)
()
((data event-message-block :inline :dynamic)
)
:method-count-assert 15
:size-assert #x10
:flag-assert #xf00000010
;; Failed to read fields.
(:methods
(event-message-block-array-method-14 () none) ;; 14
(send-all! (_type_) none) ;; 14
)
)
|#
(deftype process (process-tree)
((pool dead-pool)
@@ -825,104 +839,126 @@
:size-assert #x80
:flag-assert #xe00000080
(:methods
;; (new (symbol type string int) _type_ 0)
(new "Allocate a process, set up process heap, self/ppointer, clock." (symbol type string int) _type_) ;; 0
)
(:states
dead-state ;; 10
)
)
;; (deftype sql-result (array)
;; ()
;; :flag-assert #x900000010
;; )
(deftype sql-result (array)
((sql-data object :dynamic :offset 16))
(:methods
(new (symbol type int) _type_) ;; 0
)
:flag-assert #x900000010
)
;; (define-extern *sql-result* object) ;; sql-result
(define-extern *sql-result* sql-result)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gkernel ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (define-extern *kernel-version* object) ;; binteger
;; (define-extern *irx-version* object) ;; binteger
;; (define-extern *kernel-boot-mode* object) ;; symbol
;; (define-extern *kernel-boot-level* object) ;; symbol
;; (define-extern *deci-count* object) ;; int
;; (define-extern *last-loado-length* object) ;; int
;; (define-extern *last-loado-global-usage* object) ;; int
;; (define-extern *last-loado-debug-usage* object) ;; int
;; (define-extern *kernel-packages* object) ;; pair
;; (define-extern load-package function) ;; (function string kheap pair)
;; (define-extern unload-package function) ;; (function string pair)
;; (define-extern *kernel-context* kernel-context) ;; kernel-context
;; (define-extern *dram-stack* object) ;; (pointer uint8)
;; (define-extern *null-kernel-context* kernel-context) ;; kernel-context
;; (define-extern remove-exit function) ;; (function none :behavior process)
;; (define-extern stream<-process-mask function) ;; (function object process-mask process-mask)
;; (define-extern *master-mode* object) ;; symbol
;; (define-extern *pause-lock* object) ;; symbol
;; (define-extern inspect-process-heap function) ;; (function process symbol)
;; (define-extern return-from-thread function) ;; (function none)
;; (define-extern return-from-thread-dead function) ;; (function none)
;; (define-extern reset-and-call function) ;; (function thread function object)
;; (define-extern method-state function) ;; (function type basic state)
;; (define-extern *global-search-name* object) ;; basic
;; (define-extern *global-search-count* object) ;; int
;; (define-extern process-by-name function) ;; (function string process-tree process)
;; (define-extern process-not-name function) ;; (function string process-tree process)
;; (define-extern process-count function) ;; (function process-tree int)
;; (define-extern kill-by-name function) ;; (function string process-tree symbol)
;; (define-extern kill-by-type function) ;; (function type process-tree symbol)
;; (define-extern kill-not-name function) ;; (function string process-tree symbol)
;; (define-extern kill-not-type function) ;; (function type process-tree symbol)
;; (define-extern kill-by-type-inherited function)
;; (define-extern iterate-process-tree function) ;; (function process-tree (function object object) kernel-context object)
;; (define-extern execute-process-tree function) ;; (function process-tree (function object object) kernel-context object)
;; (define-extern search-process-tree function) ;; (function process-tree (function process-tree object) process)
;; (define-extern kernel-dispatcher function) ;; (function object)
;; (define-extern sync-dispatcher function) ;; (function object)
;; (define-extern inspect-process-tree function) ;; (function process-tree int int symbol process-tree)
;; (define-extern throw-dispatch function) ;; (function catch-frame object none)
;; (define-extern throw function) ;; (function symbol object int)
;; (define-extern previous-brother function) ;; (function process-tree object)
;; (define-extern change-parent function) ;; (function process-tree process-tree process-tree)
;; (define-extern change-brother function) ;; (function process-tree process-tree object)
;; (define-extern change-to-last-brother function) ;; (function process-tree process-tree)
;; (define-extern run-function-in-process function) ;; (function process function object object object object object object object)
;; (define-extern set-to-run-bootstrap function) ;; (function none)
;; (define-extern set-to-run function) ;; (function cpu-thread function object object object object object object pointer)
;; (define-extern dead-state state) ;; (state process)
;; (define-extern entity-deactivate-handler object) ;; (function process entity-actor none)
;; (define-extern *kernel-clock* clock) ;; clock
;; (define-extern *vis-boot* object) ;; symbol
;; (define-extern *null-process* object) ;; process
;; (define-extern *listener-process* object) ;; process
;; (define-extern *16k-dead-pool* object) ;; dead-pool
;; (define-extern *8k-dead-pool* object) ;; dead-pool
;; (define-extern *4k-dead-pool* object) ;; dead-pool
;; (define-extern *target-dead-pool* object) ;; dead-pool
;; (define-extern *camera-dead-pool* object) ;; dead-pool
;; (define-extern *camera-master-dead-pool* object) ;; dead-pool
;; (define-extern *debug-dead-pool* object) ;; dead-pool-heap
;; (define-extern *nk-dead-pool* object) ;; dead-pool-heap
;; (define-extern *default-dead-pool* object) ;; dead-pool
;; (define-extern *pickup-dead-pool* object) ;; dead-pool
;; (define-extern *dead-pool-list* object) ;; pair
;; (define-extern *active-pool* object) ;; process-tree
;; (define-extern *display-pool* object) ;; process-tree
;; (define-extern *camera-pool* object) ;; process-tree
;; (define-extern *target-pool* object) ;; process-tree
;; (define-extern *entity-pool* object) ;; process-tree
;; (define-extern *mid-pool* object) ;; process-tree
;; (define-extern *pusher-pool* object) ;; process-tree
;; (define-extern *bg-pool* object) ;; process-tree
;; (define-extern *default-pool* object) ;; process-tree
(define-extern *kernel-version* binteger)
(define-extern *irx-version* binteger)
(define-extern *kernel-boot-mode* symbol)
(define-extern *kernel-boot-level* symbol)
(define-extern *deci-count* int)
(define-extern *last-loado-length* int)
(define-extern *last-loado-global-usage* int)
(define-extern *last-loado-debug-usage* int)
(define-extern *kernel-packages* pair)
(define-extern load-package
"If not already loaded, do a blocking dgo-load to load the given CGO."
(function string kheap pair))
(define-extern unload-package
"Mark a package as unloaded. Does not actually unload."
(function string pair))
(define-extern *kernel-context* kernel-context)
(define-extern *dram-stack* (pointer uint8))
(define-extern *null-kernel-context* kernel-context)
(define-extern remove-exit
"Remove the top stack frame. If you have no other stack frames, you can use this before a `go`
to skip the `exit` of the state you are currently in."
(function none :behavior process))
(define-extern stream<-process-mask
"Print out the process-mask as a human readable string."
(function object process-mask process-mask))
(define-extern *master-mode* symbol)
(define-extern *pause-lock* symbol)
(define-extern inspect-process-heap
"Call the inspect method on every object in the process heap."
(function process symbol))
(define-extern return-from-thread (function none))
(define-extern return-from-thread-dead (function none))
(define-extern reset-and-call (function thread function object))
(define-extern method-state
"Get a virtual state from this type by name."
(function type symbol state))
(define-extern *global-search-name* basic)
(define-extern *global-search-count* int)
(define-extern process-by-name
"Find the first process with the given name in the process-tree."
(function string process-tree process))
(define-extern process-not-name
"Find the first process without the given name in the process-tree."
(function string process-tree process))
(define-extern process-count
"Count the number of processes in the given process-tree."
(function process-tree int))
(define-extern kill-by-name "Kill all processes with the given name." (function string process-tree symbol))
(define-extern kill-by-type "Kill all processes with the given type." (function type process-tree symbol))
(define-extern kill-not-name "Kill all processes, except ones with the given name." (function string process-tree symbol))
(define-extern kill-not-type "Kill all processes, except ones with the exact type." (function type process-tree symbol))
(define-extern kill-by-type-inherited "Kill all processes, except ones that inherit from the given type." (function type process-tree symbol))
(define-extern iterate-process-tree "Call a function on each not-dead process in the tree." (function process-tree (function object object) kernel-context object))
(define-extern execute-process-tree "Iterate over all process, calling the run callback on each, if they should run." (function process-tree (function object object) kernel-context object))
(define-extern search-process-tree "Return the first function in the process-tree which the callback returns #t on." (function process-tree (function process-tree object) process))
(define-extern kernel-dispatcher "Run the GOAL kernel! Runs the function from the listener (if there is one), then all processes" (function object))
(define-extern sync-dispatcher "Run the REPL function." (function object))
(define-extern inspect-process-tree "Display a tree-view of a process-tree." (function process-tree int int symbol process-tree))
(define-extern throw-dispatch (function catch-frame object none))
(define-extern throw (function symbol object int))
(define-extern previous-brother "Get the process before this one, at this level." (function process-tree object))
(define-extern change-parent "Reparent a process." (function process-tree process-tree process-tree))
(define-extern change-brother "Unused, and wrong." (function process-tree process-tree object))
(define-extern change-to-last-brother "Move this process to the end of its brother list." (function process-tree process-tree))
(define-extern run-function-in-process (function process function object object object object object object object))
(define-extern set-to-run-bootstrap (function none))
(define-extern set-to-run "Set up a process to run a given function, with the given arguments when it executes next." (function cpu-thread function object object object object object object pointer))
(define-extern dead-state (state process))
(define-extern entity-deactivate-handler (function process entity-actor none))
(define-extern *kernel-clock* clock)
(define-extern *vis-boot* symbol)
(define-extern *null-process* process)
(define-extern *listener-process* process)
(define-extern *16k-dead-pool* dead-pool)
(define-extern *8k-dead-pool* dead-pool)
(define-extern *4k-dead-pool* dead-pool)
(define-extern *target-dead-pool* dead-pool)
(define-extern *camera-dead-pool* dead-pool)
(define-extern *camera-master-dead-pool* dead-pool)
(define-extern *debug-dead-pool* dead-pool-heap)
(define-extern *nk-dead-pool* dead-pool-heap)
(define-extern *default-dead-pool* dead-pool)
(define-extern *pickup-dead-pool* dead-pool)
(define-extern *dead-pool-list* pair)
(define-extern *active-pool* process-tree)
(define-extern *display-pool* process-tree)
(define-extern *camera-pool* process-tree)
(define-extern *target-pool* process-tree)
(define-extern *entity-pool* process-tree)
(define-extern *mid-pool* process-tree)
(define-extern *pusher-pool* process-tree)
(define-extern *bg-pool* process-tree)
(define-extern *default-pool* process-tree)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pskernel ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#|
(deftype lowmemmap (structure)
((irq-info-stack uint32 :offset-assert 0)
(irq2-info-stack uint32 :offset-assert 4)
@@ -943,80 +979,117 @@
:size-assert #x44
:flag-assert #x900000044
)
|#
;; (define-extern kernel-copy-function function) ;; (function object (pointer int32) int32 int32 none)
;; (define-extern kernel-copy-to-kernel-ram function) ;; (function none)
;; (define-extern kernel-write-function function) ;; (function object object object none)
;; (define-extern kernel-write function) ;; (function none)
;; (define-extern kernel-read-function function) ;; (function object (pointer int32) none)
;; (define-extern kernel-read function) ;; (function none)
;; (define-extern kernel-check-hardwired-addresses function) ;; (function none)
;; (define-extern install-default-debug-handler function) ;; (function object none)
;; (define-extern return-from-exception function) ;; (function object none)
;; (define-extern kernel-set-exception-vector function) ;; (function object none)
;; (define-extern kernel-set-interrupt-vector function) ;; (function none)
;; (define-extern kernel-set-level2-vector function) ;; (function object object none)
;; (define-extern deinstall-debug-handler function) ;; (function none)
;; (define-extern deinstall-debug-handlers function) ;; (function none)
;; (define-extern resend-exception function) ;; (function object object object object none)
(define-extern kernel-copy-function (function object (pointer int32) int32 int32 none))
(define-extern kernel-copy-to-kernel-ram (function none))
(define-extern kernel-write-function (function object object object none))
(define-extern kernel-write (function none))
(define-extern kernel-read-function (function object (pointer int32) none))
(define-extern kernel-read (function none))
(define-extern kernel-check-hardwired-addresses (function none))
(define-extern install-default-debug-handler (function object none))
(define-extern return-from-exception (function object none))
(define-extern kernel-set-exception-vector (function object none))
(define-extern kernel-set-interrupt-vector (function none))
(define-extern kernel-set-level2-vector (function object object none))
(define-extern deinstall-debug-handler (function none))
(define-extern deinstall-debug-handlers (function none))
(define-extern resend-exception (function object object object object none))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gstring ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (define-extern copy-string<-string function) ;; (function string string string)
;; (define-extern string= function) ;; (function string string symbol)
;; (define-extern string-prefix= function) ;; (function string string symbol)
;; (define-extern charp-prefix= function) ;; (function (pointer uint8) (pointer uint8) symbol)
;; (define-extern string-suffix= function) ;; (function string string symbol)
;; (define-extern string-position function) ;; (function string string int)
;; (define-extern string-charp= function) ;; (function string (pointer uint8) symbol)
(define-extern name= (function object object symbol))
;; (define-extern copyn-string<-charp function) ;; (function string (pointer uint8) int string)
;; (define-extern string<-charp function) ;; (function string (pointer uint8) string)
;; (define-extern charp<-string function) ;; (function (pointer uint8) string int)
;; (define-extern copyn-charp<-string function) ;; (function (pointer uint8) string int none)
;; (define-extern copy-charp<-charp function) ;; (function (pointer uint8) (pointer uint8) (pointer uint8))
;; (define-extern cat-string<-string function) ;; (function string string string)
;; (define-extern catn-string<-charp function) ;; (function string (pointer uint8) int string)
;; (define-extern cat-string<-string_to_charp function) ;; (function string string (pointer uint8) (pointer uint8))
;; (define-extern append-character-to-string function) ;; (function string uint8 int)
;; (define-extern charp-basename function) ;; (function (pointer uint8) (pointer uint8))
;; (define-extern clear function) ;; (function string string)
;; (define-extern string<? function) ;; (function string string symbol)
;; (define-extern string>? function) ;; (function string string symbol)
;; (define-extern string<=? function) ;; (function string string symbol)
;; (define-extern string>=? function) ;; (function string string symbol)
;; (define-extern *string-tmp-str* object) ;; string
;; (define-extern string-skip-to-char function) ;; (function (pointer uint8) uint (pointer uint8))
;; (define-extern string-cat-to-last-char function) ;; (function string string uint (pointer uint8))
;; (define-extern string-skip-whitespace function) ;; (function (pointer uint8) (pointer uint8))
;; (define-extern string-suck-up! function) ;; (function string (pointer uint8) symbol)
;; (define-extern string-strip-leading-whitespace! function) ;; (function string symbol)
;; (define-extern string-strip-trailing-whitespace! function) ;; (function string symbol)
;; (define-extern string-strip-whitespace! function) ;; (function string symbol)
;; (define-extern string-upcase function) ;; (function string string none)
;; (define-extern string-get-arg!! function) ;; (function string string symbol)
;; (define-extern string->int function) ;; (function string int)
;; (define-extern string->float function) ;; (function string float)
;; (define-extern string-get-int32!! function) ;; (function (pointer int32) string symbol)
;; (define-extern string-get-float!! function) ;; (function (pointer float) string symbol)
;; (define-extern string-get-flag!! function) ;; (function (pointer symbol) string string string symbol)
;; (define-extern string-word-wrap function) ;; (function string int none)
;; (define-extern *debug-draw-pauseable* object) ;; symbol
;; (define-extern *stdcon0* object) ;; string
;; (define-extern *stdcon1* object) ;; string
;; (define-extern *null* object)
;; (define-extern *stdcon* object) ;; string
;; (define-extern *stdebug* object)
;; (define-extern *temp-string* object) ;; string
(define-extern copy-string<-string
"Copy a string. No bounds check. Writes null terminator." (function string string string))
(define-extern string=
"Check for string equality."
(function string string symbol))
(define-extern string-prefix=
"Check if a string starts with a given string."
(function string string symbol))
(define-extern charp-prefix=
"Check if a c-string starts with a given c-string."
(function (pointer uint8) (pointer uint8) symbol))
(define-extern string-suffix=
"Check if a string ends with a given string."
(function string string symbol))
(define-extern string-position
"Find the point where a string occurs in another. If it doesn't, return -1."
(function string string int))
(define-extern string-charp=
"Check if a string is equal to a c-string." (function string (pointer uint8) symbol))
(define-extern name=
"Check if a string/symbol stores the same name as another string/symbol."
(function object object symbol))
(define-extern copyn-string<-charp
"Copy part of a c-string to a string. Writes null terminator after num-chars." (function string (pointer uint8) int string))
(define-extern string<-charp
"Copy a c-string to a string. Writes the null terminator."
(function string (pointer uint8) string))
(define-extern charp<-string
"Copy a string to a c-string. Writes the null terminator."
(function (pointer uint8) string int))
(define-extern copyn-charp<-string
"Copy part of a string to a c-string. Writes null terminator, repeatedly, to reach the given length.
If the source is longer than the length, the null terminator is still included."
(function (pointer uint8) string int none))
(define-extern copy-charp<-charp
"C-string copy, writes null terminator."
(function (pointer uint8) (pointer uint8) (pointer uint8)))
(define-extern cat-string<-string
"Append a string to another."
(function string string string))
(define-extern catn-string<-charp
"Append part of a string to another. Writes null terminator."
(function string (pointer uint8) int string))
(define-extern cat-string<-string_to_charp "Append part of a string to another, up to the given pointer."
(function string string (pointer uint8) (pointer uint8)))
(define-extern append-character-to-string
"Append a single character to a string. Writes null terminator after."
(function string uint8 int))
(define-extern charp-basename
"Strip the directory and suffix from a c-string."
(function (pointer uint8) (pointer uint8)))
(define-extern clear "Set string to the empty string."
(function string string))
(define-extern string<?
"Slightly incorrect ordering of strings."
(function string string symbol))
(define-extern string>? "Slightly incorrect ordering of strings." (function string string symbol))
(define-extern string<=? "Slightly incorrect ordering of strings." (function string string symbol))
(define-extern string>=? "Slightly incorrect ordering of strings." (function string string symbol))
(define-extern *string-tmp-str* string)
(define-extern string-skip-to-char "Advance to the given character."
(function (pointer uint8) uint (pointer uint8)))
(define-extern string-cat-to-last-char "Append append-str to end of base-str, up to the last occurance of char" (function string string uint (pointer uint8)))
(define-extern string-skip-whitespace "Jump over whitespace chars."
(function (pointer uint8) (pointer uint8)))
(define-extern string-suck-up! "Move the string forward so the pointer is now at the beginning."
(function string (pointer uint8) symbol))
(define-extern string-strip-leading-whitespace! "Strip leading whitespace." (function string symbol))
(define-extern string-strip-trailing-whitespace! "String trailing whitespace." (function string symbol))
(define-extern string-strip-whitespace! "Strip whitespace from the beginning and end of a string" (function string symbol))
(define-extern string-upcase "Uppercase characters. If convert-dash is set, - will be uppercased to _" (function string string symbol none))
(define-extern string-get-arg!! (function string string symbol))
(define-extern string->int "Convert string to int." (function string int))
(define-extern string->float "Convert string to float. Finally implemented!" (function string float))
(define-extern string-get-int32!! (function (pointer int32) string symbol))
(define-extern string-get-float!! (function (pointer float) string symbol))
(define-extern string-get-flag!! (function (pointer symbol) string string string symbol))
(define-extern string-word-wrap "Wrap lines to specified width." (function string int none))
(define-extern *debug-draw-pauseable* symbol)
(define-extern *stdcon0* string)
(define-extern *stdcon1* string)
(define-extern *null* string)
(define-extern *stdcon* string)
(define-extern *stdebug* string)
(define-extern *temp-string* string)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; dgo-h ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
#|
(deftype dgo-header (structure)
((length uint32 :offset-assert 0)
(rootname uint8 60 :offset-assert 4) ;; guessed by decompiler
@@ -1025,9 +1098,7 @@
:size-assert #x40
:flag-assert #x900000040
)
|#
#|
(deftype dgo-entry (structure)
((offset uint32 :offset-assert 0)
(length uint32 :offset-assert 4)
@@ -1036,9 +1107,7 @@
:size-assert #x8
:flag-assert #x900000008
)
|#
#|
(deftype dgo-file (basic)
((num-go-files uint32 :offset-assert 4)
(total-length uint32 :offset-assert 8)
@@ -1049,19 +1118,18 @@
:size-assert #x10
:flag-assert #x900000010
)
|#
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; gstate ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (define-extern inherit-state function) ;; (function state state state)
;; (define-extern state-type? function)
;; (define-extern enter-state function) ;; (function object object object object object object object)
;; (define-extern *event-queue* object) ;; event-message-block-array
;; (define-extern send-event-function function) ;; (function process-tree event-message-block object)
;; (define-extern looping-code function) ;; (function symbol)
(define-extern inherit-state (function state state state))
(define-extern state-type? (function state symbol symbol))
(define-extern enter-state (function object object object object object object object))
(define-extern *event-queue* event-message-block-array)
(define-extern send-event-function (function process-tree event-message-block object))
(define-extern looping-code (function symbol))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; types-h ;;
@@ -5527,6 +5595,7 @@
)
|#
(declare-type level-load-info basic)
#|
(deftype level-load-info (basic)
((name-list symbol 6 :offset-assert 4) ;; guessed by decompiler
@@ -5592,6 +5661,7 @@
)
|#
(declare-type level basic)
#|
(deftype level (basic)
((name symbol :offset-assert 4) ;; guessed by decompiler
@@ -6406,7 +6476,7 @@
|#
;; (define-extern connection-process-apply function) ;; (function process (function object none) symbol)
;; (define-extern process-disconnect function) ;; (function process int)
(define-extern process-disconnect (function process int))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; text-h ;;
@@ -24577,7 +24647,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; (define-extern *task-level* array) ;; (array symbol)
;; (define-extern default-level level-load-info) ;; level-load-info
(define-extern default-level level-load-info)
;; (define-extern intro level-load-info) ;; level-load-info
;; (define-extern title level-load-info) ;; level-load-info
;; (define-extern vinroom level-load-info) ;; level-load-info
@@ -24893,7 +24963,7 @@
;; (define-extern sound-bank-name->mode function)
;; (define-extern update-sound-banks function) ;; (function int)
;; (define-extern show-level function) ;; (function symbol int)
;; (define-extern *default-level* object) ;; level
(define-extern *default-level* level)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; text ;;
decompiler/config/jak3/ntsc_v1/anonymous_function_types.jsonc
+11 -1
View File
@@ -1 +1,11 @@
{}
{
"gkernel": [
[17, "(function process symbol)"],
[24, "(function process symbol)"],
[26, "(function process symbol)"],
[29, "(function process symbol)"],
[32, "(function process symbol)"],
[34, "(function process symbol)"],
[36, "(function process symbol)"]
]
}
decompiler/config/jak3/ntsc_v1/type_casts.jsonc
+36 -2
View File
@@ -31,9 +31,43 @@
],
"(method 0 cpu-thread)": [[[0, 35], "v0", "cpu-thread"]],
"(method 0 process)": [
// [11, "a0", "int"],
// [[12, 45], "v0", "process"]
[11, "a0", "int"],
[[12, 52], "v0", "process"]
],
"inspect-process-heap": [
[[4, 11], "s5", "basic"],
[17, "s5", "pointer"]
],
"(method 14 dead-pool)": [
[[24, 25], "v1", "(pointer process)"],
[[30, 39], "s4", "(pointer process)"]
],
"(method 24 dead-pool-heap)": [
[5, "v1", "pointer"],
[13, "a0", "pointer"],
[25, "v1", "pointer"]
],
"(method 14 dead-pool)": [
[[24, 25], "v1", "(pointer process)"],
[[30, 39], "s4", "(pointer process)"]
],
"method-state": [[12, "a2", "state"]],
"(method 0 protect-frame)": [
[0, "a0", "int"],
[[1, 8], "v0", "protect-frame"]
],
"(method 9 process)": [[[58, 61], "s5", "process"]],
"(method 10 process)": [[[24, 30], "s4", "protect-frame"]],
"string-cat-to-last-char": [
[3, "s5", "(pointer uint8)"],
[4, "s5", "string"]
],
"enter-state": [
[70, "s0", "protect-frame"],
[103, "t9", "(function object object object object object object none)"]
],
"send-event-function": [[[7, 15], "a0", "process"]],
"logf": [
[12, "f0", "float"],
[12, "f1", "float"],
decompiler/config/jak3/ntsc_v1/var_names.jsonc
+236
View File
@@ -167,6 +167,173 @@
"err-msg-dest"
]
},
"(method 0 process-tree)": {
"args": ["allocation", "type-to-make", "name"]
},
"(method 0 process)": {
"args": ["allocation", "type-to-make", "name"]
},
"(method 9 process-tree)": {
"args": ["this", "active-tree", "name", "stack-pointer"]
},
"(method 9 process)": {
"args": ["this", "active-tree", "name", "stack-pointer"]
},
"(method 10 process-tree)": {
"args": ["this", "ent"]
},
"(method 0 clock)": {
"args": ["allocation", "type-to-make", "index"]
},
"(method 9 clock)": {
"args": ["this", "rate"]
},
"(method 16 clock)": {
"args": ["this", "xor-val"]
},
"(method 17 clock)": {
"args": ["this", "xor-val"]
},
"(method 18 clock)": {
"args": ["this", "xor-val"]
},
"(method 19 clock)": {
"args": ["this", "xor-val"]
},
"(method 20 clock)": {
"args": ["this", "xor-val"]
},
"(method 21 clock)": {
"args": ["this", "xor-val"]
},
"(method 22 clock)": {
"args": ["this", "xor-val"]
},
"(method 23 clock)": {
"args": ["this", "xor-val"]
},
"(method 9 thread)": {
"args": ["this", "size-bytes"]
},
"(method 0 cpu-thread)": {
"args": [
"allocation",
"type-to-make",
"proc",
"name",
"stack-size",
"stack-top"
]
},
"(method 0 dead-pool)": {
"args": ["allocation", "type-to-make", "num-proc", "process-size", "name"]
},
"(method 14 dead-pool)": {
"args": ["this", "proc-type", "proc-size", "unk"]
},
"(method 14 dead-pool-heap)": {
"args": ["this", "proc-type", "proc-size", "unk"]
},
"(method 15 dead-pool)": {
"args": ["this", "proc"]
},
"(method 15 dead-pool-heap)": {
"args": ["this", "proc"]
},
"(method 0 dead-pool-heap)": {
"args": ["allocation", "type-to-make", "name", "max-num-proc", "heap-size"]
},
"(method 16 dead-pool-heap)": {
"args": ["this", "allocation", "heap-size"]
},
"(method 17 dead-pool-heap)": {
"args": ["this", "compact-count"]
},
"(method 18 dead-pool-heap)": {
"args": ["this", "proc"]
},
"(method 19 dead-pool-heap)": {
"args": ["this", "count"]
},
"(method 24 dead-pool-heap)": {
"args": ["this", "first-rec"]
},
"(method 25 dead-pool-heap)": {
"args": ["this", "rec"]
},
"(method 26 dead-pool-heap)": {
"args": ["this", "first-rec"]
},
"(method 27 dead-pool-heap)": {
"args": ["this", "size"]
},
"(method 0 protect-frame)": {
"args": ["stack-addr", "type-to-make", "exit-func"]
},
"(method 0 process)": {
"args": ["allocation", "type-to-make", "name", "process-heap-size"]
},
"(method 0 sql-result)": {
"args": ["allocation", "type-to-make", "num-elts"]
},
"load-package": {
"args": ["package-name", "heap"]
},
"unload-package": {
"args": ["package-name"]
},
"inspect-process-heap": {
"args": ["proc"]
},
"method-state": {
"args": ["typ", "state-name"]
},
"process-by-name": {
"args": ["process-name", "tree"]
},
"process-not-name": {
"args": ["name", "tree"]
},
"process-count": {
"args": ["tree"]
},
"kill-by-name": {
"args": ["name", "tree"]
},
"kill-by-type": {
"args": ["typ", "tree"]
},
"kill-not-name": {
"args": ["name", "tree"]
},
"kill-not-type": {
"args": ["typ", "tree"]
},
"kill-by-type-inherited": {
"args": ["typ", "tree"]
},
"iterate-process-tree": {
"args": ["tree", "callback", "context"]
},
"execute-process-tree": {
"args": ["tree", "callback", "context"]
},
"search-process-tree": {
"args": ["tree", "callback"]
},
"inspect-process-tree": {
"args": ["tree", "depth", "mask", "detail"]
},
"previous-brother": {
"args": ["tree"]
},
"change-parent": {
"args": ["proc-to-change", "new-parent"]
},
"change-to-last-brother": {
"args": ["proc"]
},
"matrix-transpose!": {
"args": ["dst", "src"]
},
@@ -178,5 +345,74 @@
},
"vector-rad<-vector-deg!": {
"args": ["out", "in"]
},
"copy-string<-string": {
"args": ["dst", "src"]
},
"string=": {
"args": ["a", "b"]
},
"string-prefix=": {
"args": ["prefix", "str"]
},
"charp-prefix=": {
"args": ["prefix", "str"]
},
"string-suffix=": {
"args": ["suffix", "str"]
},
"string-position": {
"args": ["substr", "base-str"]
},
"string-charp=": {
"args": ["a", "b"]
},
"name=": {
"args": ["a", "b"]
},
"copyn-string<-charp": {
"args": ["dst", "src", "num-chars"]
},
"string<-charp": {
"args": ["dst", "src"]
},
"charp<-string": {
"args": ["dst", "src"]
},
"copyn-charp<-string": {
"args": ["dst", "src", "len"]
},
"copy-charp<-charp": {
"args": ["dst", "src"]
},
"cat-string<-string": {
"args": ["dst", "src"]
},
"catn-string<-charp": {
"args": ["dst", "src", "num-chars"]
},
"cat-string<-string_to_charp": {
"args": ["dst", "src", "stop-ptr"]
},
"append-character-to-string": {
"args": ["str", "char"]
},
"charp-basename": {
"args": ["str"]
},
"clear": {
"args": ["str"]
},
"string<?": {
"args": ["a", "b"]
},
"string>?": {
"args": ["a", "b"]
},
"string<=?": {
"args": ["a", "b"]
},
"string>=?": {
"args": ["a", "b"]
}
}
game/common/dgo_rpc_types.h
+7 -1
View File
@@ -26,6 +26,10 @@ struct RPC_Dgo_Cmd {
uint32_t buffer2;
uint32_t buffer_heap_top;
char name[16];
// note: padding this a bit so the jak 3 commands can get sent to overlord without overflowing
// a buffer.
uint8_t pad[32];
};
namespace jak3 {
@@ -40,4 +44,6 @@ struct RPC_Dgo_Cmd {
uint8_t pad[30];
};
static_assert(sizeof(RPC_Dgo_Cmd) == 0x40);
} // namespace jak3
} // namespace jak3
static_assert(sizeof(RPC_Dgo_Cmd) == sizeof(jak3::RPC_Dgo_Cmd));
game/overlord/jak2/iso_cd.cpp
+8 -7
View File
@@ -80,6 +80,13 @@ uint32_t FS_LoadSoundBank(char* name, SoundBank* buffer);
uint32_t FS_LoadMusic(char* name, snd::BankHandle* buffer);
u32 FS_SyncRead();
struct FakeCd {
int offset_into_file = 0;
FILE* fp = nullptr;
void (*callback)(int) = nullptr;
FileRecord* last_fr = nullptr;
} gFakeCd;
void iso_cd_init_globals() {
ReadPagesCurrentPage = nullptr;
DvdSema = -1;
@@ -110,6 +117,7 @@ void iso_cd_init_globals() {
iso_cd.load_sound_bank = FS_LoadSoundBank;
iso_cd.load_music = FS_LoadMusic;
iso_cd.sync_read = FS_SyncRead;
gFakeCd.last_fr = nullptr;
}
static FILE* open_fr(FileRecord* fr, s32 thread_to_wake) {
@@ -124,13 +132,6 @@ static FILE* open_fr(FileRecord* fr, s32 thread_to_wake) {
// Sony Fake CD Functions
///////////////////////////
struct FakeCd {
int offset_into_file = 0;
FILE* fp = nullptr;
void (*callback)(int) = nullptr;
FileRecord* last_fr = nullptr;
} gFakeCd;
auto sceCdCallback(void (*callback)(int)) {
auto ret = gFakeCd.callback;
gFakeCd.callback = callback;
game/runtime.cpp
+1
View File
@@ -229,6 +229,7 @@ void ee_runner(SystemThreadInterface& iface) {
break;
case GameVersion::Jak3:
jak3::goal_main(g_argc, g_argv);
break;
default:
ASSERT_MSG(false, "Unsupported game version");
}
goal_src/jak3/kernel/dgo-h.gc
+21
View File
@@ -7,3 +7,24 @@
;; DECOMP BEGINS
(deftype dgo-header (structure)
((length uint32)
(rootname uint8 60)
)
)
(deftype dgo-entry (structure)
((offset uint32)
(length uint32)
)
)
(deftype dgo-file (basic)
((num-go-files uint32)
(total-length uint32)
(rsvd uint32)
(data uint8 :dynamic)
)
)
goal_src/jak3/kernel/gcommon.gc
+127
View File
@@ -1444,3 +1444,130 @@ over a normal (array uint32), since both store data the same way."
)
)
)
;;;;;;;;;;;;;;;;;;;;
;; 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-pc-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 cmove-#f-nonzero (dest condition src)
`(if (zero? ,condition)
(set! ,dest ,src)
(set! ,dest #f)
)
)
(defmacro empty-form ()
`(none)
)
(defmacro sext32 (in)
`(sar (shl ,in 32) 32)
)
(defmacro .sra (result in sa)
`(set! ,result (sext32 (sar (logand #xffffffff (the-as int ,in)) ,sa)))
)
(defmacro l32-false-check (in)
`(- (logand #xffffffff (the-as uint ,in)) (the-as uint #f))
)
;;;;;;;;;;;;;;;;;;;;;;;
;; 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)
;; Move to perf counter register
(fake-asm .mtpc src dest)
;; Move from perf counter register
(fake-asm .mfpc dest src)
)
goal_src/jak3/kernel/gkernel-h.gc
+181 -114
View File
@@ -5,7 +5,9 @@
;; name in dgo: gkernel-h
;; dgos: KERNEL
;; DECOMP BEGINS
;; Note: this file has a lot of manual edits.
(defglobalconstant KERNEL_DEBUG #t)
(defconstant *kernel-major-version* 2)
(defconstant *kernel-minor-version* 0)
@@ -13,7 +15,6 @@
(defconstant DPROCESS_STACK_SIZE (#if PC_PORT #x8000 #x3800))
(defconstant PROCESS_STACK_SIZE (#if PC_PORT #x4000 #x1c00))
;; the size of the shared heap used by dynamically sized processes
(#if PC_BIG_MEMORY
(defconstant PROCESS_HEAP_MULT 4) ;; 4x actors
(defconstant PROCESS_HEAP_MULT 1)
@@ -24,51 +25,46 @@
(defconstant *tab-size* (the binteger 8))
(defconstant *gtype-basic-offset* 4)
;; if set, will attempt to detect memory corruption and stack overflow bugs
;; to some extent.
(defglobalconstant KERNEL_DEBUG #t)
(defconstant *scratch-memory-top* (the pointer #x70004000))
(defenum process-mask
:type uint32
:bitfield #t
(execute 0) ;; 1
(execute 0)
(freeze 1)
(pause 2)
(menu 3)
(progress 4)
(actor-pause 5) ;; 32
(sleep 6) ;; 64
(sleep-code 7) ;; 128
(process-tree 8) ;; 256
(heap-shrunk 9) ;; 512
(going 10) ;; 1024
(kernel-run 11) ;; 2048
(no-kill 12) ;; 4096
(movie 13) ;; 8192
(dark-effect 14) ;; 0x4000
(target 15) ;; 0x8000
(actor-pause 5)
(sleep 6)
(sleep-code 7)
(process-tree 8)
(heap-shrunk 9)
(going 10)
(kernel-run 11)
(no-kill 12)
(movie 13)
(dark-effect 14)
(target 15)
(sidekick 16) ;; 0x1'0000
(crate 17) ;; 0x2'0000
(collectable 18) ;; 0x4'0000
(enemy 19) ;; 0x8'0000
(camera 20) ;; 0x10'0000
(platform 21) ;; 0x20'0000
(ambient 22) ;; 0x40'0000
(entity 23) ;; 0x80'0000
(projectile 24) ;; 0x100'0000
(bot 25) ;; 0x200'0000
(death 26) ;; 0x400'0000
(guard 27) ;; 0x800'0000
(vehicle 28) ;; 0x1000'0000
(civilian 29) ;; 0x2000'0000
(kg-robot 30) ;; 0x4000'0000
(metalhead 31) ;; 0x8000'0000
(sidekick 16)
(crate 17)
(collectable 18)
(enemy 19)
(camera 20)
(platform 21)
(ambient 22)
(entity 23)
(projectile 24)
(bot 25)
(death 26)
(guard 27)
(vehicle 28)
(civilian 29)
(kg-robot 30)
(metalhead 31)
)
;; forward declarations
(declare-type process-tree basic)
(declare-type process process-tree)
(declare-type res-lump basic)
@@ -79,8 +75,9 @@
(declare-type state basic)
(declare-type event-message-block structure)
(declare-type stack-frame basic)
(declare-type thread basic)
(declare-type cpu-thread thread)
(declare-type cpu-thread basic)
;; DECOMP BEGINS
(deftype kernel-context (basic)
((prevent-from-run process-mask)
@@ -128,6 +125,30 @@
)
)
;; Each clock counts in 3 different ways:
;;
;; 1). A "frame counter", which, confusingly, doesn't count frames.
;; It counts elapsed time, in 1/300ths of a second.
;; This counts in real-time, even if the game is lagging.
;;
;; 2). A "integral-frame-counter", which counts the number of vsyncs.
;; This doens't count the number of frames the game actually manages to draw,
;; just the number of vsyncs. It counts at different rates in NTSC/PAL.
;; NOTE: changing clock-ratio will make this count faster/slower. This only counts real
;; vsyncs if clock-ratio is 1.0.
;;
;; 3). The "time ratio", which adjusts based on the actual achieved framerate.
;; Unlike the others, this isn't a incrementing counter, but instead ratios:
;; time-adjust-ratio, frames-per-second, seconds-per-frame.
;;
;; For the most part, users should just adjust per-frame values by time-adjust-ratio, and this will
;; compensate for pal/ntsc, lag, and clock-ratio scaling.
;;
;; The clock won't tick if its process-mask is prevent-from-run in the kernel.
;; A clock can change the rate it runs at with clock-ratio.
;; Note: both integral-frame-counter and seconds-per-frame/frames-per-second are affected by
;; clock-ratio, which is somewhat weird.
;; Changing clock-ratio will make integral-frame-counter not count actual vsyncs
(deftype clock (basic)
((index int16)
@@ -165,41 +186,49 @@
)
)
(defmethod frame-mask-2 ((this clock) (arg0 int))
(not (logtest? (logxor arg0 (the-as int (-> this integral-frame-counter))) 1))
(defmethod frame-mask-2 ((this clock) (xor-val int))
"Check if the frame count, xored with `xor-val` has its lowest bit set"
(not (logtest? (logxor xor-val (the-as int (-> this integral-frame-counter))) 1))
)
(defmethod frame-mask-4 ((this clock) (arg0 int))
(not (logtest? (logxor arg0 (the-as int (-> this integral-frame-counter))) 3))
(defmethod frame-mask-4 ((this clock) (xor-val int))
"Check if the frame count, xored with `xor-val` has any of its lowest 2 bits set"
(not (logtest? (logxor xor-val (the-as int (-> this integral-frame-counter))) 3))
)
(defmethod frame-mask-8 ((this clock) (arg0 int))
(not (logtest? (logxor arg0 (the-as int (-> this integral-frame-counter))) 7))
(defmethod frame-mask-8 ((this clock) (xor-val int))
"Check if the frame count, xored with `xor-val` has any of its lowest 3 bits set"
(not (logtest? (logxor xor-val (the-as int (-> this integral-frame-counter))) 7))
)
(defmethod frame-mask-16 ((this clock) (arg0 int))
(not (logtest? (logxor arg0 (the-as int (-> this integral-frame-counter))) 15))
(defmethod frame-mask-16 ((this clock) (xor-val int))
"Check if the frame count, xored with `xor-val` has any of its lowest 4 bits set"
(not (logtest? (logxor xor-val (the-as int (-> this integral-frame-counter))) 15))
)
(defmethod frame-mask-32 ((this clock) (arg0 int))
(not (logtest? (logxor arg0 (the-as int (-> this integral-frame-counter))) 31))
(defmethod frame-mask-32 ((this clock) (xor-val int))
"Check if the frame count, xored with `xor-val` has any of its lowest 5 bits set"
(not (logtest? (logxor xor-val (the-as int (-> this integral-frame-counter))) 31))
)
(defmethod frame-mask-64 ((this clock) (arg0 int))
(not (logtest? (logxor arg0 (the-as int (-> this integral-frame-counter))) 63))
(defmethod frame-mask-64 ((this clock) (xor-val int))
"Check if the frame count, xored with `xor-val` has any of its lowest 6 bits set"
(not (logtest? (logxor xor-val (the-as int (-> this integral-frame-counter))) 63))
)
(defmethod frame-mask-128 ((this clock) (arg0 int))
(not (logtest? (logxor arg0 (the-as int (-> this integral-frame-counter))) 127))
(defmethod frame-mask-128 ((this clock) (xor-val int))
"Check if the frame count, xored with `xor-val` has any of its lowest 7 bits set"
(not (logtest? (logxor xor-val (the-as int (-> this integral-frame-counter))) 127))
)
(defmethod frame-mask-256 ((this clock) (arg0 int))
(not (logtest? (logxor arg0 (the-as int (-> this integral-frame-counter))) 255))
(defmethod frame-mask-256 ((this clock) (xor-val int))
"Check if the frame count, xored with `xor-val` has any of its lowest 8 bits set"
(not (logtest? (logxor xor-val (the-as int (-> this integral-frame-counter))) 255))
)
(defmethod new clock ((allocation symbol) (type-to-make type) (arg0 int))
(defmethod new clock ((allocation symbol) (type-to-make type) (index int))
(let ((gp-0 (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
(set! (-> gp-0 index) arg0)
(set! (-> gp-0 index) index)
(set! (-> gp-0 frame-counter) (the-as uint #x493e0))
(set! (-> gp-0 integral-frame-counter) (the-as uint #x493e0))
(set! (-> gp-0 old-frame-counter) (+ (-> gp-0 frame-counter) -1))
@@ -209,6 +238,9 @@
)
)
;; The basic node used to organize processes into a tree.
;; The process types themselves are children of the process-tree type
;; Typically, each instance of a game object is a process.
(deftype process-tree (basic)
((name string)
(mask process-mask)
@@ -221,7 +253,7 @@
)
(:methods
(new (symbol type string) _type_)
(activate (_type_ process-tree basic pointer) process-tree)
(activate (_type_ process-tree string pointer) process-tree)
(deactivate (_type_) none)
(init-from-entity! (_type_ entity-actor) none) ;; todo check
(run-logic? (_type_) symbol)
@@ -242,9 +274,9 @@
(stack-size int32)
)
(:methods
(thread-method-9 () none)
(thread-method-10 () none)
(thread-method-11 () none)
(stack-size-set! (_type_ int) none)
(thread-suspend (_type_) none)
(thread-resume (_type_) none)
)
)
@@ -258,11 +290,46 @@
)
)
(deftype process (process-tree)
((pool dead-pool)
(status symbol)
(pid int32)
(main-thread cpu-thread)
(top-thread cpu-thread)
(entity entity-actor)
(level level)
(state state)
(prev-state state)
(next-state state)
(state-stack basic)
(trans-hook function)
(post-hook function)
(event-hook (function process int symbol event-message-block object))
(allocated-length int32)
(heap-base pointer)
(heap-top pointer)
(heap-cur pointer)
(stack-frame-top stack-frame)
(connection-list connectable :inline)
(stack uint8 :dynamic)
)
:method-count-assert 14
:size-assert #x80
:flag-assert #xe00000080
(:methods
(new "Allocate a process, set up process heap, self/ppointer, clock." (symbol type string int) _type_) ;; 0
)
(:states
dead-state ;; 10
)
)
(deftype dead-pool (process-tree)
()
(:methods
(dead-pool-method-14 () none)
(dead-pool-method-15 () none)
(new (symbol type int int string) _type_)
(get-process (_type_ type int object) process)
(return-process (_type_ process) none)
)
)
@@ -286,21 +353,22 @@
(alive-list dead-pool-heap-rec :inline)
(last dead-pool-heap-rec :overlay-at (-> alive-list prev))
(dead-list dead-pool-heap-rec :inline)
(process-list dead-pool-heap-rec :dynamic)
(process-list dead-pool-heap-rec :inline :dynamic)
)
(:methods
(dead-pool-heap-method-16 () none)
(dead-pool-heap-method-17 () none)
(dead-pool-heap-method-18 () none)
(dead-pool-heap-method-19 () none)
(dead-pool-heap-method-20 () none)
(dead-pool-heap-method-21 () none)
(dead-pool-heap-method-22 () none)
(dead-pool-heap-method-23 () none)
(dead-pool-heap-method-24 () none)
(dead-pool-heap-method-25 () none)
(dead-pool-heap-method-26 () none)
(dead-pool-heap-method-27 () none)
(new (symbol type string int int) _type_)
(init (_type_ symbol int) none)
(compact (dead-pool-heap int) none)
(shrink-heap (dead-pool-heap process) dead-pool-heap)
(churn (dead-pool-heap int) none)
(memory-used (_type_) int)
(memory-total (_type_) int)
(memory-free (dead-pool-heap) int)
(compact-time (dead-pool-heap) uint)
(gap-size (dead-pool-heap dead-pool-heap-rec) int)
(gap-location (dead-pool-heap dead-pool-heap-rec) pointer)
(find-gap (dead-pool-heap dead-pool-heap-rec) dead-pool-heap-rec)
(find-gap-by-size (dead-pool-heap int) dead-pool-heap-rec)
)
)
@@ -317,15 +385,20 @@
(rreg uint128 7)
)
(:methods
(new (symbol type symbol function (pointer uint64)) object)
(new (symbol type symbol function (pointer uint64)) object) ;; 0
)
)
(deftype protect-frame (stack-frame)
((exit (function object))
)
(:methods
(new (symbol type (function object)) protect-frame)
)
)
(deftype handle (uint64)
((process (pointer process) :offset 0 :size 32)
(pid int32 :offset 32 :size 32)
@@ -346,24 +419,6 @@
)
)
(defmethod inspect handle ((this handle))
(when (not this)
(return this)
)
(format #t "[~8x] ~A~%" this 'handle)
(format #t "~1Tprocess: #x~X~%" (-> this process))
(format #t "~1Tpid: ~D~%" (-> this pid))
this
)
; (defmethod print ((this handle))
; (if (nonzero? this)
; (format #t "#<handle :process ~A :pid ~D>" (handle->process this) (-> this pid))
; (format #t "#<handle :process 0 :pid 0>")
; )
; this
; )
(defmacro ppointer->process (ppointer)
"convert a (pointer process) to a process."
;; this uses the self field, which seems to always just get set to the object.
@@ -393,20 +448,35 @@
)
(defmethod print ((this handle))
(if (nonzero? this)
(format #t "#<handle :process ~A :pid ~D>" (handle->process this) (-> this pid))
(format #t "#<handle :process 0 :pid 0>")
)
this
)
(deftype state (protect-frame)
((parent basic)
((parent state)
(code function)
(trans (function object))
(post function)
(enter function)
(event (function process int symbol event-message-block object))
)
(:methods
(new (symbol type symbol function
(function object)
function
(function object)
(function process int symbol event-message-block object)) _type_) ;; 0
)
)
(deftype event-message-block (structure)
((to-handle uint64)
((to-handle handle)
(to (pointer process) :overlay-at to-handle)
(from-handle uint64)
(from-handle handle)
(from (pointer process) :overlay-at from-handle)
(param uint64 6)
(message symbol)
@@ -415,32 +485,35 @@
)
(deftype event-message-block-array (inline-array-class)
((data event-message-block :dynamic)
((data event-message-block :inline :dynamic)
)
(:methods
(event-message-block-array-method-14 () none)
(send-all! (_type_) none)
)
)
(set! (-> event-message-block-array heap-base) (the-as uint 80))
(deftype sql-result (array)
((result-data object :dynamic :offset 16)
((sql-data object :dynamic :offset 16)
)
(:methods
(new (symbol type int) _type_)
)
)
; (defmethod new sql-result ((allocation symbol) (type-to-make type) (arg0 type) (arg1 int))
; (let ((v0-0 (object-new allocation type-to-make (the-as int (+ (-> type-to-make size) (* arg0 4))))))
; (set! (-> v0-0 allocated-length) (the-as int arg0))
; (set! (-> v0-0 content-type) (the-as type 'error))
; v0-0
; )
; )
(defmethod new sql-result ((allocation symbol) (type-to-make type) (num-elts int))
(let ((v0-0 (object-new allocation type-to-make (the-as int (+ (-> type-to-make size) (* num-elts 4))))))
(set! (-> v0-0 allocated-length) num-elts)
(set! (-> v0-0 content-type) (the-as type 'error))
v0-0
)
)
(defmethod print ((this sql-result))
(format #t "#(~A" (-> this content-type))
(dotimes (s5-0 (-> this length))
(format #t " ~A" (-> this result-data s5-0))
(format #t " ~A" (-> this sql-data s5-0))
)
(format #t ")")
this
@@ -448,11 +521,6 @@
(define *sql-result* (the-as sql-result #f))
;; failed to figure out what this is:
0
(defmacro defbehavior (name process-type bindings &rest body)
"define a new behavior. This is simply a function where self is bound to the process register,
which is assumed to have type process-type."
@@ -617,5 +685,4 @@
(defmacro time-elapsed? (time duration)
`(>= (- (current-time) ,time) ,duration)
)
)
goal_src/jak3/kernel/gkernel.gc
+2362 -15
View File
File diff suppressed because it is too large Load Diff
goal_src/jak3/kernel/gstate.gc
+459
View File
@@ -5,5 +5,464 @@
;; name in dgo: gstate
;; dgos: KERNEL
(defmacro go (next-state &rest args)
"Change the state of the current process.
This will only return if this is called within the post thread.
Otherwise, execution stops here and the kernel will run the next state next time."
`(with-pp
(go-hook pp ,next-state ,@args)
)
)
;; disable for now, since the extra arg to get-process is unknown.
; (defmacro process-spawn-function (proc-type func &key (from *default-dead-pool*) &key (to *default-pool*) &key (name #f) &key (stack-size #x4000) &key (stack *scratch-memory-top*) &rest args)
; "Start a new process that runs a function on its main thread.
; Returns a pointer to the new process (or #f? on error)."
; (with-gensyms (new-proc)
; `(let ((,new-proc (the-as ,proc-type (get-process ,from ,proc-type ,stack-size))))
; (when ,new-proc
; ((method-of-type ,proc-type activate) ,new-proc ,to ,(if name name `(symbol->string ',proc-type)) ,stack)
; (run-next-time-in-process ,new-proc ,func ,@args)
; (the (pointer ,proc-type) (-> ,new-proc ppointer))
; )
; )
; )
; )
; (defmacro process-spawn (proc-type &key (init #f) &key (from *default-dead-pool*) &key (to *default-pool*) &key (name #f) &key (stack-size #x4000) &key (stack *scratch-memory-top*) &rest args)
; "Start a new process and run an init function on it.
; Returns a pointer to the new process, or #f (or is it 0?) if something goes wrong."
; (with-gensyms (new-proc)
; `(let ((,new-proc (the-as ,proc-type (get-process ,from ,proc-type ,stack-size))))
; (when ,new-proc
; ((method-of-type ,proc-type activate) ,new-proc ,to ,(if name name `(symbol->string ',proc-type)) ,stack)
; (run-now-in-process ,new-proc ,(if init init (string->symbol (fmt #f "{}-init-by-other" proc-type))) ,@args)
; (the (pointer ,proc-type) (-> ,new-proc ppointer))
; )
; )
; )
; )
(defmacro go-virtual (state-name &key (proc self) &rest args)
"Same as go, but use a virtual state."
`(go (method-of-object ,proc ,state-name) ,@args)
)
(defmacro go-process (proc next-state &rest args)
"Make another process go."
`(with-pp
(protect (pp)
(set! pp ,proc)
(go-hook pp ,next-state ,@args)
)
)
)
;; run the given function in a process right now.
;; will return to here when:
;; - you return
;; - you deactivate
;; - you go
;; - you throw to 'initialize
(defmacro run-now-in-process (proc func &rest args)
"Run a function in another process right now."
`((the (function _varargs_ object) run-function-in-process)
,proc ,func ,@args
)
)
;; sets the main thread of the given process to run the given thing.
;; this resets the main thread stack back to the top
(defmacro run-next-time-in-process (proc func &rest args)
"Set up a process to run a function the next time it is scheduled."
`((the (function _varargs_ object) set-to-run)
(-> ,proc main-thread) ,func ,@args
)
)
;; use a compile-time list to keep track of the type of an anonymous behavior.
(seval (define *defstate-type-stack* '()))
(desfun def-state-check-behavior (beh-form beh-type)
"check if code block is an anonymous behavior. needed for anonymous behaviors on defstate."
(when (and (pair? beh-form) (eq? (first beh-form) 'behavior))
(push! *defstate-type-stack* beh-type)
)
)
(defmacro clear-def-state-stack ()
(set! *defstate-type-stack* '())
`(none)
)
;; set when inside a defstate.
(seval (define *defstate-current-type* #f))
(seval (define *defstate-current-state-name* #f))
;; *no-state* is just used for the compiler to know whether a handler was actually set or not
(defmacro defstate (state-name parents
&key (virtual #f)
&key (event *no-state*)
&key (enter *no-state*)
&key (trans *no-state*)
&key (exit *no-state*)
&key (code *no-state*)
&key (post *no-state*)
)
"Define a new state!"
(with-gensyms (new-state)
(let ((defstate-type (first parents)))
(when (not (null? *defstate-type-stack*))
(fmt #t "*defstate-type-stack* leaked! An error probably happened in a previous defstate. stack is: {}"
*defstate-type-stack*)
)
(set! *defstate-type-stack* '())
(when virtual
(set! *defstate-current-type* defstate-type)
(set! *defstate-current-state-name* state-name)
)
;; check for default handlers
(let ((default-handlers (assoc defstate-type *default-state-handlers*)))
(when default-handlers
;;(fmt #t "found default-handlers for {}: {}\n" defstate-type default-handlers)
;; event
(set! default-handlers (cadr default-handlers))
(when (and (eq? event '*no-state*) (car default-handlers))
(set! event (car default-handlers)))
;; enter
(set! default-handlers (cdr default-handlers))
(when (and (eq? enter '*no-state*) (car default-handlers))
(set! enter (car default-handlers)))
;; trans
(set! default-handlers (cdr default-handlers))
(when (and (eq? trans '*no-state*) (car default-handlers))
(set! trans (car default-handlers)))
;; exit
(set! default-handlers (cdr default-handlers))
(when (and (eq? exit '*no-state*) (car default-handlers))
(set! exit (car default-handlers)))
;; code
(set! default-handlers (cdr default-handlers))
(when (and (eq? code '*no-state*) (car default-handlers))
(set! code (car default-handlers)))
;; post
(set! default-handlers (cdr default-handlers))
(when (and (eq? post '*no-state*) (car default-handlers))
(set! post (car default-handlers)))
(set! default-handlers (cdr default-handlers))
)
)
(def-state-check-behavior event defstate-type)
(def-state-check-behavior enter defstate-type)
(def-state-check-behavior trans defstate-type)
(def-state-check-behavior exit defstate-type)
(def-state-check-behavior code defstate-type)
(def-state-check-behavior post defstate-type)
`(let ((,new-state (new 'static 'state
:name (quote ,state-name)
:next #f
:exit #f
:code #f
:trans #f
:post #f
:enter #f
:event #f
)
))
;; the compiler will set the fields of the given state and define the symbol.
;; This way it can check the individual function types, make sure they make sense, and create
;; a state with the appropriate type.
,(if virtual
`(define-virtual-state-hook ,state-name ,defstate-type ,new-state ,(eq? virtual 'override) :event ,event :enter ,enter :trans ,trans :exit ,exit :code ,code :post ,post)
`(define-state-hook ,state-name ,defstate-type ,new-state :event ,event :enter ,enter :trans ,trans :exit ,exit :code ,code :post ,post)
)
)
)
)
)
(defmacro find-parent-state ()
"Find the first different implementation of the current virtual state above this one."
(when (or (not *defstate-current-type*)
(not *defstate-current-state-name*))
(error "use of find-parent-state outside of a defstate.")
)
`(cast-to-method-type
,*defstate-current-type*
,*defstate-current-state-name*
(find-parent-method ,*defstate-current-type* (method-id-of-type ,*defstate-current-type* ,*defstate-current-state-name*))
)
)
(defmacro behavior (bindings &rest body)
"Define an anonymous behavior for a process state. This may only be used inside a defstate!"
(let ((behavior-type (first *defstate-type-stack*)))
(pop! *defstate-type-stack*)
`(lambda :behavior ,behavior-type ,bindings ,@body)
)
)
;; set the default handler functions for a process's state handlers
(seval (define *default-state-handlers* '()))
(defmacro defstatehandler (proc
&key (event #f)
&key (enter #f)
&key (trans #f)
&key (exit #f)
&key (code #f)
&key (post #f))
(let ((old (assoc proc *default-state-handlers*))
(new (list proc (list event enter trans exit code post))))
(if (not old)
(append!! *default-state-handlers* new) ;; add new set of default handlers
(dolist (hnd *default-state-handlers*) ;; replace old handlers with new ones
(when (eq? (car hnd) old)
(set-car! hnd new)
)
)
)
)
`(none)
)
;; DECOMP BEGINS
(defmethod new state ((allocation symbol)
(type-to-make type)
(arg0 symbol)
(arg1 function)
(arg2 (function object))
(arg3 function)
(arg4 (function object))
(arg5 (function process int symbol event-message-block object))
)
(let ((v0-0 (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
(set! (-> v0-0 name) arg0)
(set! (-> v0-0 next) #f)
(set! (-> v0-0 parent) #f)
(set! (-> v0-0 exit) arg4)
(set! (-> v0-0 code) arg1)
(set! (-> v0-0 trans) arg2)
(set! (-> v0-0 post) #f)
(set! (-> v0-0 enter) arg3)
(set! (-> v0-0 event) arg5)
v0-0
)
)
(defun inherit-state ((arg0 state) (arg1 state))
(set! (-> arg0 parent) (-> arg1 parent)) ;; huh???
(set! (-> arg0 exit) (-> arg1 exit))
(set! (-> arg0 code) (-> arg1 code))
(set! (-> arg0 trans) (-> arg1 trans))
(set! (-> arg0 post) (-> arg1 post))
(set! (-> arg0 enter) (-> arg1 enter))
(set! (-> arg0 event) (-> arg1 event))
arg0
)
(defmethod print ((this state))
(format #t "#<~A ~A @ #x~X>" (-> this type) (-> this name) this)
this
)
(defun state-type? ((arg0 state) (arg1 symbol))
(let ((v1-0 arg0))
(while v1-0
(if (= (-> v1-0 name) arg1)
(return #t)
)
(set! v1-0 (-> v1-0 parent))
)
)
#f
)
(define-extern enter-state (function object object object object object object object))
(defun enter-state ((arg0 object) (arg1 object) (arg2 object) (arg3 object) (arg4 object) (arg5 object))
(local-vars (s7-0 none) (sp-0 int) (ra-0 int))
(with-pp
;; added!!
(if (zero? (-> pp next-state))
(break!))
(logclear! (-> pp mask) (process-mask sleep sleep-code))
(logior! (-> pp mask) (process-mask going))
(cond
((= (-> pp status) 'initialize)
(set! (-> pp trans-hook) #f)
(set-to-run (-> pp main-thread) enter-state arg0 arg1 arg2 arg3 arg4 arg5)
(set! (-> pp status) 'initialize-go)
(throw 'initialize #t)
#t
)
((!= (-> *kernel-context* current-process) pp)
(let ((s0-0 (-> pp status)))
(set! (-> pp trans-hook) #f)
(set-to-run (-> pp main-thread) enter-state arg0 arg1 arg2 arg3 arg4 arg5)
(set! (-> pp status) s0-0)
)
#t
)
((= (-> pp main-thread) (-> pp top-thread))
(set! (-> pp prev-state) (-> pp state))
(set! (-> pp state) (-> pp next-state))
(let ((s0-1 (-> pp stack-frame-top)))
(while s0-1
(case (-> s0-1 type)
((protect-frame state)
((-> (the-as protect-frame s0-1) exit))
)
)
(set! s0-1 (-> s0-1 next))
)
)
(logclear! (-> pp mask) (process-mask going))
(let ((s0-2 (-> pp state)))
(set! (-> pp event-hook) (-> s0-2 event))
(if (-> s0-2 exit)
(set! (-> pp stack-frame-top) s0-2)
(set! (-> pp stack-frame-top) #f)
)
(set! (-> pp post-hook) (-> s0-2 post))
(set! (-> pp trans-hook) (-> s0-2 trans))
(let ((t9-4 (-> s0-2 enter)))
(if t9-4
((the-as (function object object object object object object none) t9-4) arg0 arg1 arg2 arg3 arg4 arg5)
)
)
(let ((t9-5 (-> s0-2 trans)))
(if t9-5
(t9-5)
)
)
(rlet ((temp)
(func)
(sp :reg rsp :type uint)
(off :reg r15 :type uint)
(carg0 :reg rdi)
(carg1 :reg rsi)
(carg2 :reg rdx)
(carg3 :reg rcx))
;; prepare args
;; compiler will likely have these on the stack, we need to get them in regs
;; before messing with the stack.
(.mov carg0 arg0)
(.mov carg1 arg1)
(.mov carg2 arg2)
(.mov carg3 arg3)
;; get the main code as an x86-64 pointer
(.mov func (-> s0-2 code))
(.add func off)
;; reset the stack (scary)
(.mov sp (-> pp main-thread stack-top))
(.add sp off)
;; push the return trampoline for when code returns.
(.mov temp return-from-thread-dead) ;; will deactivate
(.add temp off)
(.push temp)
;; and call!
(.jr func)
;; stupid hack so the compiler doesn't throw away these registers.
(.add carg0 carg1)
(.add carg2 carg3)
#f ;; can't get here
)
; (let ((v1-29 (-> pp main-thread)))
; (.lwu sp-0 28 v1-29)
; )
; (let ((t9-6 (-> s0-2 code)))
; (.lw ra-0 return-from-thread-dead s7-0)
; (.jr t9-6)
; )
)
arg4
)
(else
(set! (-> pp trans-hook) #f)
(set-to-run (-> pp main-thread) enter-state arg0 arg1 arg2 arg3 arg4 arg5)
(when (!= (-> pp top-thread name) 'post)
;; abandon this one too.
;; NOTE - this is different from GOAL.
;; GOAL installs this as the return address for this function and returns normally.
;; but we don't because I don't have an easy way to find where to stick this.
;; I can't see how this makes a difference, as all non-main threads seem
;; temporary, but if this turns out to be false, we will need to change this.
(abandon-thread)
#f ;; can't get here
; (let ((v1-32 return-from-thread))
; (.sw v1-32 0 (the-as none sp-0))
; )
)
#t
)
)
)
)
(kmemopen global "event-queue")
(let ((v1-4 (new 'global 'event-message-block-array 64)))
(set! (-> v1-4 length) 0)
(define *event-queue* v1-4) ;; og:preserve-this
)
(kmemclose)
(defun send-event-function ((arg0 process-tree) (arg1 event-message-block))
(with-pp
(when (and arg0 (!= (-> arg0 type) process-tree) (-> (the-as process arg0) event-hook) (-> arg1 from))
(let ((gp-0 pp))
(set! pp (the-as process arg0))
(let ((v0-0 ((-> (the-as process arg0) event-hook) (-> arg1 from 0) (-> arg1 num-params) (-> arg1 message) arg1)))
(set! pp gp-0)
v0-0
)
)
)
)
)
(defmethod send-all! ((this event-message-block-array))
(dotimes (s5-0 (-> this length))
(let* ((a1-0 (-> this data s5-0))
(a0-2 (handle->process (-> a1-0 to-handle)))
)
(if (and a0-2 (handle->process (-> a1-0 from-handle)))
(send-event-function a0-2 a1-0)
)
)
)
(set! (-> this length) 0)
0
(none)
)
;; WARN: new jak 2 until loop case, check carefully
(defun looping-code ()
(until #f
(suspend)
)
#f
)
(defmacro send-event (proc msg &key (from (with-pp pp)) &rest params)
"Send an event to a process. This should be used over send-event-function"
`(let ((event-data (new 'stack-no-clear 'event-message-block)))
(set! (-> event-data from) (process->ppointer ,from))
(set! (-> event-data num-params) ,(length params))
(set! (-> event-data message) ,msg)
,@(apply-i (lambda (x i) `(set! (-> event-data param ,i) (the-as uint ,x))) params)
(send-event-function ,proc event-data)
)
)
goal_src/jak3/kernel/gstring-h.gc
+7
View File
@@ -7,3 +7,10 @@
;; DECOMP BEGINS
(define-extern *string-tmp-str* string)
(define-extern *temp-string* string)
(define-extern *stdcon0* string)
(define-extern *stdcon1* string)
(define-extern *stdcon* string)
(define-extern *debug-draw-pauseable* symbol)
(define-extern string= (function string string symbol))
goal_src/jak3/kernel/gstring.gc
+793
View File
@@ -7,3 +7,796 @@
;; DECOMP BEGINS
(defmethod length ((this string))
(let ((v1-0 (-> this data)))
(while (nonzero? (-> v1-0 0))
(nop!)
(nop!)
(nop!)
(set! v1-0 (&-> v1-0 1))
)
(&- v1-0 (the-as uint (-> this data)))
)
)
(defmethod asize-of ((this string))
(+ (-> this allocated-length) 1 (-> string size))
)
(defun copy-string<-string ((dst string) (src string))
"Copy a string. No bounds check. Writes null terminator."
(let ((v1-0 (-> dst data)))
(let ((a1-1 (-> src data)))
(while (nonzero? (-> a1-1 0))
(set! (-> v1-0 0) (-> a1-1 0))
(set! v1-0 (&-> v1-0 1))
(set! a1-1 (&-> a1-1 1))
)
)
(set! (-> v1-0 0) (the-as uint 0))
)
dst
)
(defmethod new string ((allocation symbol) (type-to-make type) (arg0 int) (arg1 string))
(cond
(arg1
(let* ((s2-1 (max (length arg1) arg0))
(a0-4 (object-new allocation type-to-make (+ s2-1 1 (-> type-to-make size))))
)
(set! (-> a0-4 allocated-length) s2-1)
(copy-string<-string a0-4 arg1)
)
)
(else
(let ((v0-2 (object-new allocation type-to-make (+ arg0 1 (-> type-to-make size)))))
(set! (-> v0-2 allocated-length) arg0)
v0-2
)
)
)
)
(defun string= ((a string) (b string))
"Check for string equality."
(let ((a2-0 (-> a data))
(v1-0 (-> b data))
)
(if (or (zero? a) (zero? b))
(return #f)
)
(while (and (nonzero? (-> a2-0 0)) (nonzero? (-> v1-0 0)))
(if (!= (-> a2-0 0) (-> v1-0 0))
(return #f)
)
(set! a2-0 (&-> a2-0 1))
(set! v1-0 (&-> v1-0 1))
)
(and (zero? (-> a2-0 0)) (zero? (-> v1-0 0)))
)
)
(defun string-prefix= ((prefix string) (str string))
"Check if a string starts with a given string."
(let ((v1-0 (-> prefix data)))
(let ((a2-0 (-> str data)))
(if (or (zero? prefix) (zero? str))
(return #f)
)
(while (and (nonzero? (-> v1-0 0)) (nonzero? (-> a2-0 0)))
(if (!= (-> v1-0 0) (-> a2-0 0))
(return #f)
)
(set! v1-0 (&-> v1-0 1))
(set! a2-0 (&-> a2-0 1))
)
)
(zero? (-> v1-0 0))
)
)
(defun charp-prefix= ((prefix (pointer uint8)) (str (pointer uint8)))
"Check if a c-string starts with a given c-string."
(while (and (nonzero? (-> prefix 0)) (nonzero? (-> str 0)))
(if (!= (-> prefix 0) (-> str 0))
(return #f)
)
(set! prefix (&-> prefix 1))
(set! str (&-> str 1))
)
(zero? (-> prefix 0))
)
(defun string-suffix= ((suffix string) (str string))
"Check if a string ends with a given string."
(let ((s5-0 (-> suffix data))
(gp-0 (-> str data))
)
(if (or (zero? suffix) (zero? str))
(return #f)
)
(let ((s4-0 (length suffix))
(v1-5 (length str))
)
(if (< s4-0 v1-5)
(return #f)
)
(let ((v1-7 (&+ s5-0 (- s4-0 v1-5))))
(while (and (nonzero? (-> v1-7 0)) (nonzero? (-> gp-0 0)))
(if (!= (-> v1-7 0) (-> gp-0 0))
(return #f)
)
(set! v1-7 (&-> v1-7 1))
(set! gp-0 (&-> gp-0 1))
)
(zero? (-> v1-7 0))
)
)
)
)
(defun string-position ((substr string) (base-str string))
"Find the point where a string occurs in another. If it doesn't, return -1."
(let ((s5-0 0)
(s4-0 (-> base-str data))
)
(while (nonzero? (-> s4-0 0))
(if (charp-prefix= (-> substr data) s4-0)
(return s5-0)
)
(+! s5-0 1)
(set! s4-0 (&-> s4-0 1))
)
)
-1
)
(defun string-charp= ((a string) (b (pointer uint8)))
"Check if a string is equal to a c-string."
(let ((v1-0 (-> a data)))
(while (and (nonzero? (-> v1-0 0)) (nonzero? (-> b 0)))
(if (!= (-> v1-0 0) (-> b 0))
(return #f)
)
(set! v1-0 (&-> v1-0 1))
(set! b (&-> b 1))
)
(and (zero? (-> v1-0 0)) (zero? (-> b 0)))
)
)
(defun name= ((arg0 object) (arg1 object))
"Do arg0 and arg1 have the same name?
This can use either strings or symbols"
(cond
((= arg0 arg1)
;; Either same symbols, or same string objects, fast check pass!
#t)
((and (= (rtype-of arg0) string) (= (rtype-of arg1) string))
(string= (the-as string arg0) (the-as string arg1))
)
((and (= (rtype-of arg0) string) (= (rtype-of arg1) symbol))
(string= (the-as string arg0) (symbol->string (the symbol arg1)))
)
((and (= (rtype-of arg1) string) (= (rtype-of arg0) symbol))
(string= (the-as string arg1) (symbol->string (the symbol arg0)))
)
;; no need to check symbol - symbol, that would have passed the first check.
)
)
(defun copyn-string<-charp ((dst string) (src (pointer uint8)) (num-chars int))
"Copy part of a c-string to a string. Writes null terminator after num-chars."
(let ((v1-0 (-> dst data)))
(dotimes (a3-0 num-chars)
(set! (-> v1-0 0) (-> src 0))
(set! v1-0 (&-> v1-0 1))
(set! src (&-> src 1))
)
(set! (-> v1-0 0) (the-as uint 0))
)
dst
)
(defun string<-charp ((dst string) (src (pointer uint8)))
"Copy a c-string to a string. Writes the null terminator."
(let ((v1-0 (-> dst data)))
(while (nonzero? (-> src 0))
(set! (-> v1-0 0) (-> src 0))
(set! v1-0 (&-> v1-0 1))
(set! src (&-> src 1))
)
(set! (-> v1-0 0) (the-as uint 0))
)
dst
)
(defun charp<-string ((dst (pointer uint8)) (src string))
"Copy a string to a c-string. Writes the null terminator."
(let ((v1-0 (-> src data)))
(while (nonzero? (-> v1-0 0))
(set! (-> dst 0) (-> v1-0 0))
(set! dst (&-> dst 1))
(set! v1-0 (&-> v1-0 1))
)
)
(set! (-> dst 0) (the-as uint 0))
0
)
(defun copyn-charp<-string ((dst (pointer uint8)) (src string) (len int))
"Copy part of a string to a c-string. Writes null terminator, repeatedly, to reach the given length.
If the source is longer than the length, the null terminator is still included."
(let ((v1-0 (-> src data)))
(while (and (nonzero? (-> v1-0 0)) (< 1 len))
(set! (-> dst 0) (-> v1-0 0))
(set! dst (&-> dst 1))
(set! v1-0 (&-> v1-0 1))
(set! len (+ len -1))
)
)
(while (> len 0)
(set! (-> dst 0) (the-as uint 0))
(set! dst (&-> dst 1))
(set! len (+ len -1))
)
0
(none)
)
(defun copy-charp<-charp ((dst (pointer uint8)) (src (pointer uint8)))
"C-string copy, writes null terminator."
(while (nonzero? (-> src 0))
(set! (-> dst 0) (-> src 0))
(set! dst (&-> dst 1))
(set! src (&-> src 1))
)
(set! (-> dst 0) (the-as uint 0))
dst
)
(defun cat-string<-string ((dst string) (src string))
"Append a string to another."
(let ((v1-0 (-> dst data)))
(let ((a1-1 (-> src data)))
(while (nonzero? (-> v1-0 0))
(nop!)
(nop!)
(nop!)
(set! v1-0 (&-> v1-0 1))
)
(while (nonzero? (-> a1-1 0))
(set! (-> v1-0 0) (-> a1-1 0))
(set! v1-0 (&-> v1-0 1))
(set! a1-1 (&-> a1-1 1))
)
)
(set! (-> v1-0 0) (the-as uint 0))
)
dst
)
(defun catn-string<-charp ((dst string) (src (pointer uint8)) (num-chars int))
"Append part of a string to another. Writes null terminator."
(let ((v1-0 (-> dst data)))
(while (nonzero? (-> v1-0 0))
(nop!)
(nop!)
(nop!)
(set! v1-0 (&-> v1-0 1))
)
(dotimes (a3-2 num-chars)
(set! (-> v1-0 0) (-> src 0))
(set! v1-0 (&-> v1-0 1))
(set! src (&-> src 1))
)
(set! (-> v1-0 0) (the-as uint 0))
)
dst
)
(defun cat-string<-string_to_charp ((dst string) (src string) (stop-ptr (pointer uint8)))
"Append part of a string to another, up to the given pointer."
(let ((v1-0 (-> src data))
(v0-0 (-> dst data))
)
(while (nonzero? (-> v0-0 0))
(nop!)
(nop!)
(nop!)
(set! v0-0 (&-> v0-0 1))
)
(while (and (>= (the-as int stop-ptr) (the-as int v1-0)) (nonzero? (-> v1-0 0)))
(set! (-> v0-0 0) (-> v1-0 0))
(set! v0-0 (&-> v0-0 1))
(set! v1-0 (&-> v1-0 1))
)
(set! (-> v0-0 0) (the-as uint 0))
v0-0
)
)
(defun append-character-to-string ((str string) (char uint8))
"Append a single character to a string. Writes null terminator after."
(let ((v1-0 (-> str data)))
(while (nonzero? (-> v1-0 0))
(nop!)
(nop!)
(nop!)
(set! v1-0 (&-> v1-0 1))
)
(set! (-> v1-0 0) (the-as uint char))
(set! (-> v1-0 1) (the-as uint 0))
)
0
0
)
(defun charp-basename ((str (pointer uint8)))
"Strip the directory and suffix from a c-string."
(let ((v1-0 str))
(while (nonzero? (-> v1-0 0))
(set! v1-0 (&-> v1-0 1))
)
(while (< (the-as int str) (the-as int v1-0))
(set! v1-0 (&-> v1-0 -1))
(if (or (= (-> v1-0 0) 47) (= (-> v1-0 0) 92))
(return (&-> v1-0 1))
)
)
)
str
)
(defun clear ((str string))
"Set string to the empty string."
(set! (-> str data 0) (the-as uint 0))
str
)
(defun string<? ((a string) (b string))
"Slightly incorrect ordering of strings."
(let ((s4-1 (min (length a) (length b))))
(dotimes (v1-4 s4-1)
(cond
((< (-> a data v1-4) (-> b data v1-4))
(return #t)
)
((< (-> b data v1-4) (-> a data v1-4))
(return #f)
)
)
)
)
#f
)
(defun string>? ((a string) (b string))
"Slightly incorrect ordering of strings."
(let ((s4-1 (min (length a) (length b))))
(dotimes (v1-4 s4-1)
(cond
((< (-> a data v1-4) (-> b data v1-4))
(return #f)
)
((< (-> b data v1-4) (-> a data v1-4))
(return #t)
)
)
)
)
#f
)
(defun string<=? ((a string) (b string))
"Slightly incorrect ordering of strings."
(let ((s4-1 (min (length a) (length b))))
(dotimes (v1-4 s4-1)
(cond
((< (-> a data v1-4) (-> b data v1-4))
(return #t)
)
((< (-> b data v1-4) (-> a data v1-4))
(return #f)
)
)
)
)
#t
)
(defun string>=? ((a string) (b string))
"Slightly incorrect ordering of strings."
(let ((s4-1 (min (length a) (length b))))
(dotimes (v1-4 s4-1)
(cond
((< (-> a data v1-4) (-> b data v1-4))
(return #f)
)
((< (-> b data v1-4) (-> a data v1-4))
(return #t)
)
)
)
)
#t
)
(define *string-tmp-str* (new 'global 'string 128 (the-as string #f)))
(defun string-skip-to-char ((arg0 (pointer uint8)) (arg1 uint))
"Advance to the given character."
(while (and (nonzero? (-> arg0 0)) (!= (-> arg0 0) arg1))
(set! arg0 (&-> arg0 1))
)
arg0
)
(defun string-cat-to-last-char ((arg0 string) (arg1 string) (arg2 uint))
"Append append-str to end of base-str, up to the last occurance of char"
(let ((s4-0 (&-> (the-as (pointer uint8) arg1) 3)))
(let ((v1-0 (string-skip-to-char (-> arg1 data) arg2)))
(when (= (-> v1-0 0) arg2)
(until (!= (-> v1-0 0) arg2)
(set! s4-0 v1-0)
(set! v1-0 (string-skip-to-char (&-> v1-0 1) arg2))
)
)
)
(cat-string<-string_to_charp arg0 arg1 s4-0)
)
)
(defun string-skip-whitespace ((arg0 (pointer uint8)))
"Jump over whitespace chars."
(while (and (nonzero? (-> arg0 0)) (or (= (-> arg0 0) 32) (= (-> arg0 0) 9) (= (-> arg0 0) 13) (= (-> arg0 0) 10)))
(set! arg0 (&-> arg0 1))
)
arg0
)
(defun string-suck-up! ((arg0 string) (arg1 (pointer uint8)))
"Move the string forward so the pointer is now at the beginning."
(when (!= arg1 (-> arg0 data))
(let ((v1-2 (-> arg0 data)))
(while (nonzero? (-> arg1 0))
(set! (-> v1-2 0) (-> arg1 0))
(set! v1-2 (&-> v1-2 1))
(set! arg1 (&-> arg1 1))
)
(set! (-> v1-2 0) (the-as uint 0))
)
0
)
#f
)
(defun string-strip-leading-whitespace! ((arg0 string))
"Strip leading whitespace."
(let ((a1-0 (string-skip-whitespace (-> arg0 data))))
(string-suck-up! arg0 a1-0)
)
#f
)
(defun string-strip-trailing-whitespace! ((arg0 string))
"String trailing whitespace."
(when (nonzero? (length arg0))
(let ((v1-6 (&+ (-> arg0 data) (+ (length arg0) -1))))
(while (and (>= (the-as int v1-6) (the-as int (-> arg0 data)))
(or (= (-> v1-6 0) 32) (= (-> v1-6 0) 9) (= (-> v1-6 0) 13) (= (-> v1-6 0) 10))
)
(set! v1-6 (&-> v1-6 -1))
)
(set! (-> v1-6 1) (the-as uint 0))
)
0
)
#f
)
(defun string-strip-whitespace! ((arg0 string))
"Strip whitespace from the beginning and end of a string"
(string-strip-trailing-whitespace! arg0)
(string-strip-leading-whitespace! arg0)
#f
)
;; WARN: Return type mismatch string vs none.
(defun string-upcase ((arg0 string) (arg1 string) (arg2 symbol))
"Uppercase characters. If convert-dash is set, - will be uppercased to _"
(let* ((a0-1 (-> arg0 data))
(t0-0 (the-as int (-> a0-1 0)))
(a3-0 1)
(v1-0 0)
)
(while (nonzero? (the-as uint t0-0))
(cond
((and (>= (the-as uint t0-0) (the-as uint 97)) (>= (the-as uint 122) (the-as uint t0-0)))
(set! t0-0 (the-as int (+ (the-as uint t0-0) -32)))
)
((and arg2 (= (the-as uint t0-0) 45))
(set! t0-0 95)
)
)
(set! (-> arg1 data v1-0) (the-as uint t0-0))
(set! t0-0 (the-as int (-> a0-1 a3-0)))
(+! a3-0 1)
(+! v1-0 1)
)
(set! (-> arg1 data v1-0) (the-as uint 0))
)
0
(none)
)
(defun string-get-arg!! ((arg0 string) (arg1 string))
(let ((s4-0 (string-skip-whitespace (-> arg1 data))))
(cond
((= (-> s4-0 0) 34)
(let ((s4-1 (&-> s4-0 1)))
(let ((v1-3 s4-1))
(while (and (nonzero? (-> s4-1 0)) (!= (-> s4-1 0) 34))
(set! s4-1 (&-> s4-1 1))
)
(copyn-string<-charp arg0 v1-3 (&- s4-1 (the-as uint v1-3)))
)
(if (= (-> s4-1 0) 34)
(set! s4-1 (&-> s4-1 1))
)
(let ((a1-3 (string-skip-whitespace s4-1)))
(string-suck-up! arg1 a1-3)
)
)
(return #t)
)
((nonzero? (-> s4-0 0))
(let ((v1-11 s4-0))
(while (and (nonzero? (-> s4-0 0)) (!= (-> s4-0 0) 32) (!= (-> s4-0 0) 9) (!= (-> s4-0 0) 13) (!= (-> s4-0 0) 10))
(set! s4-0 (&-> s4-0 1))
)
(copyn-string<-charp arg0 v1-11 (&- s4-0 (the-as uint v1-11)))
)
(let ((a1-9 (string-skip-whitespace s4-0)))
(string-suck-up! arg1 a1-9)
)
(return #t)
)
)
)
#f
)
(defun string->int ((arg0 string))
"Convert string to int."
(let ((a0-1 (-> arg0 data))
(v0-0 0)
(v1-0 #f)
)
(cond
((= (-> a0-1 0) 35)
(let ((a0-2 (&-> a0-1 1)))
(cond
((or (= (-> a0-2 0) 120) (= (-> a0-2 0) 88))
(let ((a0-3 (&-> a0-2 1)))
(when (= (-> a0-3 1) 45)
(set! v1-0 #t)
(set! a0-3 (&-> a0-3 1))
)
(while (or (and (>= (-> a0-3 0) (the-as uint 48)) (>= (the-as uint 57) (-> a0-3 0)))
(and (>= (-> a0-3 0) (the-as uint 65)) (>= (the-as uint 70) (-> a0-3 0)))
(and (>= (-> a0-3 0) (the-as uint 97)) (>= (the-as uint 102) (-> a0-3 0)))
)
(cond
((and (>= (-> a0-3 0) (the-as uint 65)) (>= (the-as uint 70) (-> a0-3 0)))
(set! v0-0 (the-as int (+ (-> a0-3 0) -55 (* v0-0 16))))
)
((and (>= (-> a0-3 0) (the-as uint 97)) (>= (the-as uint 102) (-> a0-3 0)))
(set! v0-0 (the-as int (+ (-> a0-3 0) -87 (* v0-0 16))))
)
(else
(set! v0-0 (the-as int (+ (-> a0-3 0) -48 (* v0-0 16))))
)
)
(set! a0-3 (&-> a0-3 1))
)
)
)
((or (= (-> a0-2 0) 98) (= (-> a0-2 0) 66))
(let ((a0-4 (&-> a0-2 1)))
(while (and (>= (-> a0-4 0) (the-as uint 48)) (>= (the-as uint 49) (-> a0-4 0)))
(set! v0-0 (the-as int (+ (-> a0-4 0) -48 (* v0-0 2))))
(set! a0-4 (&-> a0-4 1))
)
)
)
)
)
)
(else
(when (= (-> a0-1 1) 45)
(set! v1-0 #t)
(set! a0-1 (&-> a0-1 1))
)
(while (and (>= (-> a0-1 0) (the-as uint 48)) (>= (the-as uint 57) (-> a0-1 0)))
(set! v0-0 (the-as int (+ (-> a0-1 0) -48 (* 10 v0-0))))
(set! a0-1 (&-> a0-1 1))
)
)
)
(cond
(v1-0
(- v0-0)
)
(else
(empty)
v0-0
)
)
)
)
(defun string->float ((arg0 string))
"Convert string to float. Finally implemented!"
(let ((a0-1 (-> arg0 data))
(f0-0 0.0)
(v1-0 #f)
)
(when (= (-> a0-1 0) 45)
(set! v1-0 #t)
(set! a0-1 (&-> a0-1 1))
)
(while (and (>= (-> a0-1 0) (the-as uint 48)) (>= (the-as uint 57) (-> a0-1 0)))
(set! f0-0 (+ (* 10.0 f0-0) (the float (+ (-> a0-1 0) -48))))
(set! a0-1 (&-> a0-1 1))
)
(when (= (-> a0-1 0) 46)
(set! a0-1 (&-> a0-1 1))
(let ((a2-4 #xf4240)
(a1-12 0)
)
(while (and (>= (-> a0-1 0) (the-as uint 48)) (>= (the-as uint 57) (-> a0-1 0)))
(+! a1-12 (* (+ (-> a0-1 0) -48) (the-as uint a2-4)))
(set! a2-4 (/ a2-4 10))
(set! a0-1 (&-> a0-1 1))
)
(+! f0-0 (* 0.0000001 (the float a1-12)))
)
)
(when (= (-> a0-1 0) 101)
(let ((a1-16 (&-> a0-1 1))
(f1-5 0.0)
(a0-2 #f)
)
(cond
((= (-> a1-16 0) 45)
(set! a0-2 #t)
(set! a1-16 (&-> a1-16 1))
)
((= (-> a1-16 0) 43)
(set! a1-16 (&-> a1-16 1))
)
)
(while (and (>= (-> a1-16 0) (the-as uint 48)) (>= (the-as uint 57) (-> a1-16 0)))
(set! f1-5 (+ (* 10.0 f1-5) (the float (+ (-> a1-16 0) -48))))
(set! a1-16 (&-> a1-16 1))
)
(when (!= f1-5 0.0)
(let ((f2-6 1.0))
(cond
(a0-2
(dotimes (a0-3 (the int f1-5))
(set! f2-6 (* 0.1 f2-6))
(nop!)
(nop!)
)
)
(else
(dotimes (a0-6 (the int f1-5))
(set! f2-6 (* 10.0 f2-6))
(nop!)
(nop!)
)
)
)
(set! f0-0 (* f0-0 f2-6))
)
)
)
)
(if v1-0
(- f0-0)
f0-0
)
)
)
(defun string-get-int32!! ((arg0 (pointer int32)) (arg1 string))
(cond
((string-get-arg!! *string-tmp-str* arg1)
(set! (-> arg0 0) (string->int *string-tmp-str*))
#t
)
(else
#f
)
)
)
(defun string-get-float!! ((arg0 (pointer float)) (arg1 string))
(cond
((string-get-arg!! *string-tmp-str* arg1)
(set! (-> arg0 0) (string->float *string-tmp-str*))
#t
)
(else
#f
)
)
)
(defun string-get-flag!! ((arg0 (pointer symbol)) (arg1 string) (arg2 string) (arg3 string))
(cond
((string-get-arg!! *string-tmp-str* arg1)
(cond
((or (string= *string-tmp-str* arg2) (string= *string-tmp-str* arg3))
(set! (-> arg0 0) (string= *string-tmp-str* arg2))
#t
)
(else
#f
)
)
)
(else
#f
)
)
)
(defun string-word-wrap ((arg0 string) (arg1 int))
"Wrap lines to specified width."
(let ((v1-0 (-> arg0 data)))
(label cfg-1)
(let ((a2-0 0)
(a0-1 0)
)
(b! #t cfg-6 :delay (nop!))
(label cfg-2)
(b! (zero? (-> v1-0 a2-0)) cfg-11 :delay (nop!))
(if (= (-> v1-0 a2-0) 32)
(set! a0-1 a2-0)
)
(+! a2-0 1)
(label cfg-6)
(b! (< a2-0 arg1) cfg-2)
(if (zero? a0-1)
(set! a0-1 a2-0)
)
(set! (-> v1-0 a0-1) (the-as uint 10))
(&+! v1-0 (+ a0-1 1))
)
)
(goto cfg-1)
(label cfg-11)
0
(none)
)
(kmemopen global "gstring-globals")
(define *debug-draw-pauseable* #f)
(define *stdcon0* (new 'global 'string #x4000 (the-as string #f)))
(define *stdcon1* (new 'global 'string #x4000 (the-as string #f)))
(define *null* (new 'global 'string 0 (the-as string #f)))
(define *stdcon* *stdcon0*)
(define *stdebug* *stdcon1*)
(define *temp-string* (new 'global 'string 2048 (the-as string #f)))
(kmemclose)
goal_src/jak3/kernel/pskernel.gc
+1
View File
@@ -7,3 +7,4 @@
;; DECOMP BEGINS
;; skipping this. Same as jak 2. Unused debug code related to PS2 kernel/BIOS stuff.
test/decompiler/reference/jak3/decompiler-macros.gc
Generated Vendored
+225 -1
View File
@@ -54,4 +54,228 @@
(.pcpyld result upper-xmm lower-xmm)
(the uint result)
)
)
)
(defmacro handle->process (handle)
"Convert a handle to a process. If the process no longer exists, returns #f."
`(let ((the-handle (the-as handle ,handle)))
(if (-> the-handle process) ;; if we don't point to a process, kernel sets this to #f
(let ((proc (-> (-> the-handle process))))
(if (= (-> the-handle pid) (-> proc pid)) ;; make sure it's the same process
proc
)
)
)
)
)
(defmacro ppointer->process (ppointer)
"convert a (pointer process) to a process."
;; this uses the self field, which seems to always just get set to the object.
;; confirmed in Jak 1 that using self here is useless, not sure...
`(let ((the-pp ,ppointer))
(if the-pp (-> the-pp 0 self))
)
)
(defmacro defbehavior (name process-type bindings &rest body)
"define a new behavior. This is simply a function where self is bound to the process register,
which is assumed to have type process-type."
(if (and
(> (length body) 1) ;; more than one thing in function
(string? (first body)) ;; first thing is a string
)
;; then it's a docstring and we ignore it.
`(define ,name (lambda :name ,name :behavior ,process-type ,bindings ,@(cdr body)))
;; otherwise don't ignore it.
`(define ,name (lambda :name ,name :behavior ,process-type ,bindings ,@body))
)
)
(defmacro process->ppointer (proc)
"safely get a (pointer process) from a process, returning #f if invalid."
`(let ((the-proc ,proc))
(if the-proc (-> the-proc ppointer))
)
)
;; use a compile-time list to keep track of the type of an anonymous behavior.
(seval (define *defstate-type-stack* '()))
(desfun def-state-check-behavior (beh-form beh-type)
"check if code block is an anonymous behavior. needed for anonymous behaviors on defstate."
(when (and (pair? beh-form) (eq? (first beh-form) 'behavior))
(push! *defstate-type-stack* beh-type)
)
)
(defmacro clear-def-state-stack ()
(set! *defstate-type-stack* '())
`(none)
)
;; set when inside a defstate.
(seval (define *defstate-current-type* #f))
(seval (define *defstate-current-state-name* #f))
;; *no-state* is just used for the compiler to know whether a handler was actually set or not
(defmacro defstate (state-name parents
&key (virtual #f)
&key (event *no-state*)
&key (enter *no-state*)
&key (trans *no-state*)
&key (exit *no-state*)
&key (code *no-state*)
&key (post *no-state*)
)
"Define a new state!"
(with-gensyms (new-state)
(let ((defstate-type (first parents)))
(when (not (null? *defstate-type-stack*))
(fmt #t "*defstate-type-stack* leaked! An error probably happened in a previous defstate. stack is: {}"
*defstate-type-stack*)
)
(set! *defstate-type-stack* '())
(when virtual
(set! *defstate-current-type* defstate-type)
(set! *defstate-current-state-name* state-name)
)
;; check for default handlers
(let ((default-handlers (assoc defstate-type *default-state-handlers*)))
(when default-handlers
;;(fmt #t "found default-handlers for {}: {}\n" defstate-type default-handlers)
;; event
(set! default-handlers (cadr default-handlers))
(when (and (eq? event '*no-state*) (car default-handlers))
(set! event (car default-handlers)))
;; enter
(set! default-handlers (cdr default-handlers))
(when (and (eq? enter '*no-state*) (car default-handlers))
(set! enter (car default-handlers)))
;; trans
(set! default-handlers (cdr default-handlers))
(when (and (eq? trans '*no-state*) (car default-handlers))
(set! trans (car default-handlers)))
;; exit
(set! default-handlers (cdr default-handlers))
(when (and (eq? exit '*no-state*) (car default-handlers))
(set! exit (car default-handlers)))
;; code
(set! default-handlers (cdr default-handlers))
(when (and (eq? code '*no-state*) (car default-handlers))
(set! code (car default-handlers)))
;; post
(set! default-handlers (cdr default-handlers))
(when (and (eq? post '*no-state*) (car default-handlers))
(set! post (car default-handlers)))
(set! default-handlers (cdr default-handlers))
)
)
(def-state-check-behavior event defstate-type)
(def-state-check-behavior enter defstate-type)
(def-state-check-behavior trans defstate-type)
(def-state-check-behavior exit defstate-type)
(def-state-check-behavior code defstate-type)
(def-state-check-behavior post defstate-type)
`(let ((,new-state (new 'static 'state
:name (quote ,state-name)
:next #f
:exit #f
:code #f
:trans #f
:post #f
:enter #f
:event #f
)
))
;; the compiler will set the fields of the given state and define the symbol.
;; This way it can check the individual function types, make sure they make sense, and create
;; a state with the appropriate type.
,(if virtual
`(define-virtual-state-hook ,state-name ,defstate-type ,new-state ,(eq? virtual 'override) :event ,event :enter ,enter :trans ,trans :exit ,exit :code ,code :post ,post)
`(define-state-hook ,state-name ,defstate-type ,new-state :event ,event :enter ,enter :trans ,trans :exit ,exit :code ,code :post ,post)
)
)
)
)
)
(defmacro find-parent-state ()
"Find the first different implementation of the current virtual state above this one."
(when (or (not *defstate-current-type*)
(not *defstate-current-state-name*))
(error "use of find-parent-state outside of a defstate.")
)
`(cast-to-method-type
,*defstate-current-type*
,*defstate-current-state-name*
(find-parent-method ,*defstate-current-type* (method-id-of-type ,*defstate-current-type* ,*defstate-current-state-name*))
)
)
(defmacro call-parent-method (&rest args)
"Find the first different implementation of the current method in a parent type and call it with these arguments."
`((the (current-method-function-type) (find-parent-method (current-method-type) (current-method-id)))
,@args)
)
(defmacro behavior (bindings &rest body)
"Define an anonymous behavior for a process state. This may only be used inside a defstate!"
(let ((behavior-type (first *defstate-type-stack*)))
(pop! *defstate-type-stack*)
`(lambda :behavior ,behavior-type ,bindings ,@body)
)
)
;; set the default handler functions for a process's state handlers
(seval (define *default-state-handlers* '()))
(defmacro defstatehandler (proc
&key (event #f)
&key (enter #f)
&key (trans #f)
&key (exit #f)
&key (code #f)
&key (post #f))
(let ((old (assoc proc *default-state-handlers*))
(new (list proc (list event enter trans exit code post))))
(if (not old)
(append!! *default-state-handlers* new) ;; add new set of default handlers
(dolist (hnd *default-state-handlers*) ;; replace old handlers with new ones
(when (eq? (car hnd) old)
(set-car! hnd new)
)
)
)
)
`(none)
)
(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)
)
)
)
(defmacro suspend ()
'(none)
)
(defmacro empty-form ()
'(none)
)
(defmacro .sync.l ()
`(none))
test/decompiler/reference/jak3/kernel/dgo-h_REF.gc
Generated Vendored
+73
View File
@@ -0,0 +1,73 @@
;;-*-Lisp-*-
(in-package goal)
;; definition of type dgo-header
(deftype dgo-header (structure)
((length uint32)
(rootname uint8 60)
)
)
;; definition for method 3 of type dgo-header
(defmethod inspect ((this dgo-header))
(when (not this)
(set! this this)
(goto cfg-4)
)
(format #t "[~8x] ~A~%" this 'dgo-header)
(format #t "~1Tlength: ~D~%" (-> this length))
(format #t "~1Trootname[60] @ #x~X~%" (-> this rootname))
(label cfg-4)
this
)
;; definition of type dgo-entry
(deftype dgo-entry (structure)
((offset uint32)
(length uint32)
)
)
;; definition for method 3 of type dgo-entry
(defmethod inspect ((this dgo-entry))
(when (not this)
(set! this this)
(goto cfg-4)
)
(format #t "[~8x] ~A~%" this 'dgo-entry)
(format #t "~1Toffset: ~D~%" (-> this offset))
(format #t "~1Tlength: ~D~%" (-> this length))
(label cfg-4)
this
)
;; definition of type dgo-file
(deftype dgo-file (basic)
((num-go-files uint32)
(total-length uint32)
(rsvd uint32)
(data uint8 :dynamic)
)
)
;; definition for method 3 of type dgo-file
(defmethod inspect ((this dgo-file))
(when (not this)
(set! this this)
(goto cfg-4)
)
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~1Tnum-go-files: ~D~%" (-> this num-go-files))
(format #t "~1Ttotal-length: ~D~%" (-> this total-length))
(format #t "~1Trsvd: ~D~%" (-> this rsvd))
(format #t "~1Tdata[0] @ #x~X~%" (-> this data))
(label cfg-4)
this
)
;; failed to figure out what this is:
0
test/decompiler/reference/jak3/kernel/gkernel-h_REF.gc
Generated Vendored
+768
View File
@@ -0,0 +1,768 @@
;;-*-Lisp-*-
(in-package goal)
;; definition of type kernel-context
(deftype kernel-context (basic)
((prevent-from-run process-mask)
(require-for-run process-mask)
(allow-to-run process-mask)
(next-pid int32)
(fast-stack-top pointer)
(current-process process)
(relocating-process basic)
(relocating-min int32)
(relocating-max int32)
(relocating-offset int32)
(relocating-level level)
(low-memory-message symbol)
(login-object basic)
(login-art-group basic)
(login-level-index int32)
)
)
;; definition for method 3 of type kernel-context
(defmethod inspect ((this kernel-context))
(when (not this)
(set! this this)
(goto cfg-4)
)
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~1Tprevent-from-run: ~D~%" (-> this prevent-from-run))
(format #t "~1Trequire-for-run: ~D~%" (-> this require-for-run))
(format #t "~1Tallow-to-run: ~D~%" (-> this allow-to-run))
(format #t "~1Tnext-pid: ~D~%" (-> this next-pid))
(format #t "~1Tfast-stack-top: #x~X~%" (-> this fast-stack-top))
(format #t "~1Tcurrent-process: ~A~%" (-> this current-process))
(format #t "~1Trelocating-process: ~A~%" (-> this relocating-process))
(format #t "~1Trelocating-min: #x~X~%" (-> this relocating-min))
(format #t "~1Trelocating-max: #x~X~%" (-> this relocating-max))
(format #t "~1Trelocating-offset: ~D~%" (-> this relocating-offset))
(format #t "~1Trelocating-level: ~A~%" (-> this relocating-level))
(format #t "~1Tlow-memory-message: ~A~%" (-> this low-memory-message))
(format #t "~1Tlogin-object: ~A~%" (-> this login-object))
(format #t "~1Tlogin-art-group: ~A~%" (-> this login-art-group))
(format #t "~1Tlogin-level-index: ~D~%" (-> this login-level-index))
(label cfg-4)
this
)
;; definition of type time-frame
(deftype time-frame (int64)
()
)
;; definition of type clock
(deftype clock (basic)
((index int16)
(ref-count uint16)
(mask process-mask)
(clock-ratio float)
(accum float)
(integral-accum float)
(frame-counter uint64)
(old-frame-counter uint64)
(integral-frame-counter uint64)
(old-integral-frame-counter uint64)
(sparticle-data vector :inline)
(seconds-per-frame float)
(frames-per-second float)
(time-adjust-ratio float)
)
(:methods
(new (symbol type int) _type_)
(update-rates! (_type_ float) float)
(clock-method-10 () none)
(clock-method-11 () none)
(clock-method-12 () none)
(clock-method-13 () none)
(clock-method-14 () none)
(clock-method-15 () none)
(frame-mask-2 (_type_ int) symbol)
(frame-mask-4 (_type_ int) symbol)
(frame-mask-8 (_type_ int) symbol)
(frame-mask-16 (_type_ int) symbol)
(frame-mask-32 (_type_ int) symbol)
(frame-mask-64 (_type_ int) symbol)
(frame-mask-128 (_type_ int) symbol)
(frame-mask-256 (_type_ int) symbol)
)
)
;; definition for method 3 of type clock
(defmethod inspect ((this clock))
(when (not this)
(set! this this)
(goto cfg-4)
)
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~1Tindex: ~D~%" (-> this index))
(format #t "~1Tref-count: ~D~%" (-> this ref-count))
(format #t "~1Tmask: ~D~%" (-> this mask))
(format #t "~1Tclock-ratio: ~f~%" (-> this clock-ratio))
(format #t "~1Taccum: ~f~%" (-> this accum))
(format #t "~1Tintegral-accum: ~f~%" (-> this integral-accum))
(format #t "~1Tframe-counter: ~D~%" (-> this frame-counter))
(format #t "~1Told-frame-counter: ~D~%" (-> this old-frame-counter))
(format #t "~1Tintegral-frame-counter: ~D~%" (-> this integral-frame-counter))
(format #t "~1Told-integral-frame-counter: ~D~%" (-> this old-integral-frame-counter))
(format #t "~1Tsparticle-data: ~`vector`P~%" (-> this sparticle-data))
(format #t "~1Tseconds-per-frame: ~f~%" (-> this seconds-per-frame))
(format #t "~1Tframes-per-second: ~f~%" (-> this frames-per-second))
(format #t "~1Ttime-adjust-ratio: ~f~%" (-> this time-adjust-ratio))
(label cfg-4)
this
)
;; definition for method 16 of type clock
(defmethod frame-mask-2 ((this clock) (xor-val int))
"Check if the frame count, xored with `xor-val` has its lowest bit set"
(not (logtest? (logxor xor-val (the-as int (-> this integral-frame-counter))) 1))
)
;; definition for method 17 of type clock
(defmethod frame-mask-4 ((this clock) (xor-val int))
"Check if the frame count, xored with `xor-val` has any of its lowest 2 bits set"
(not (logtest? (logxor xor-val (the-as int (-> this integral-frame-counter))) 3))
)
;; definition for method 18 of type clock
(defmethod frame-mask-8 ((this clock) (xor-val int))
"Check if the frame count, xored with `xor-val` has any of its lowest 3 bits set"
(not (logtest? (logxor xor-val (the-as int (-> this integral-frame-counter))) 7))
)
;; definition for method 19 of type clock
(defmethod frame-mask-16 ((this clock) (xor-val int))
"Check if the frame count, xored with `xor-val` has any of its lowest 4 bits set"
(not (logtest? (logxor xor-val (the-as int (-> this integral-frame-counter))) 15))
)
;; definition for method 20 of type clock
(defmethod frame-mask-32 ((this clock) (xor-val int))
"Check if the frame count, xored with `xor-val` has any of its lowest 5 bits set"
(not (logtest? (logxor xor-val (the-as int (-> this integral-frame-counter))) 31))
)
;; definition for method 21 of type clock
(defmethod frame-mask-64 ((this clock) (xor-val int))
"Check if the frame count, xored with `xor-val` has any of its lowest 6 bits set"
(not (logtest? (logxor xor-val (the-as int (-> this integral-frame-counter))) 63))
)
;; definition for method 22 of type clock
(defmethod frame-mask-128 ((this clock) (xor-val int))
"Check if the frame count, xored with `xor-val` has any of its lowest 7 bits set"
(not (logtest? (logxor xor-val (the-as int (-> this integral-frame-counter))) 127))
)
;; definition for method 23 of type clock
(defmethod frame-mask-256 ((this clock) (xor-val int))
"Check if the frame count, xored with `xor-val` has any of its lowest 8 bits set"
(not (logtest? (logxor xor-val (the-as int (-> this integral-frame-counter))) 255))
)
;; definition for method 0 of type clock
(defmethod new clock ((allocation symbol) (type-to-make type) (index int))
(let ((gp-0 (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
(set! (-> gp-0 index) index)
(set! (-> gp-0 frame-counter) (the-as uint #x493e0))
(set! (-> gp-0 integral-frame-counter) (the-as uint #x493e0))
(set! (-> gp-0 old-frame-counter) (+ (-> gp-0 frame-counter) -1))
(set! (-> gp-0 old-integral-frame-counter) (+ (-> gp-0 integral-frame-counter) -1))
(update-rates! gp-0 1.0)
gp-0
)
)
;; definition of type thread
(deftype thread (basic)
((name symbol)
(process process)
(previous thread)
(suspend-hook (function cpu-thread none))
(resume-hook (function cpu-thread none))
(pc pointer)
(sp pointer)
(stack-top pointer)
(stack-size int32)
)
(:methods
(stack-size-set! (_type_ int) none)
(thread-suspend (_type_) none)
(thread-resume (_type_) none)
)
)
;; definition for method 3 of type thread
(defmethod inspect ((this thread))
(when (not this)
(set! this this)
(goto cfg-4)
)
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~1Tname: ~A~%" (-> this name))
(format #t "~1Tprocess: ~A~%" (-> this process))
(format #t "~1Tprevious: ~A~%" (-> this previous))
(format #t "~1Tsuspend-hook: ~A~%" (-> this suspend-hook))
(format #t "~1Tresume-hook: ~A~%" (-> this resume-hook))
(format #t "~1Tpc: #x~X~%" (-> this pc))
(format #t "~1Tsp: #x~X~%" (-> this sp))
(format #t "~1Tstack-top: #x~X~%" (-> this stack-top))
(format #t "~1Tstack-size: ~D~%" (-> this stack-size))
(label cfg-4)
this
)
;; definition of type cpu-thread
(deftype cpu-thread (thread)
((rreg uint64 7)
(freg float 8)
(stack uint8 :dynamic)
)
(:methods
(new (symbol type process symbol int pointer) _type_)
)
)
;; definition for method 3 of type cpu-thread
(defmethod inspect ((this cpu-thread))
(when (not this)
(set! this this)
(goto cfg-4)
)
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~1Tname: ~A~%" (-> this name))
(format #t "~1Tprocess: ~A~%" (-> this process))
(format #t "~1Tprevious: ~A~%" (-> this previous))
(format #t "~1Tsuspend-hook: ~A~%" (-> this suspend-hook))
(format #t "~1Tresume-hook: ~A~%" (-> this resume-hook))
(format #t "~1Tpc: #x~X~%" (-> this pc))
(format #t "~1Tsp: #x~X~%" (-> this sp))
(format #t "~1Tstack-top: #x~X~%" (-> this stack-top))
(format #t "~1Tstack-size: ~D~%" (-> this stack-size))
(format #t "~1Trreg[8] @ #x~X~%" (-> this rreg))
(format #t "~1Tfreg[6] @ #x~X~%" (&-> this freg 2))
(format #t "~1Tstack[0] @ #x~X~%" (-> this stack))
(label cfg-4)
this
)
;; definition of type dead-pool
(deftype dead-pool (process-tree)
()
(:methods
(new (symbol type int int string) _type_)
(get-process (_type_ type int object) process)
(return-process (_type_ process) none)
)
)
;; definition for method 3 of type dead-pool
(defmethod inspect ((this dead-pool))
(when (not this)
(set! this this)
(goto cfg-68)
)
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~1Tname: ~A~%" (-> this name))
(format #t "~1Tmask: #x~X : (process-mask " (-> this mask))
(let ((s5-0 (-> this mask)))
(if (= (logand s5-0 (process-mask process-tree)) (process-mask process-tree))
(format #t "process-tree ")
)
(if (= (logand s5-0 (process-mask target)) (process-mask target))
(format #t "target ")
)
(if (= (logand (process-mask collectable) s5-0) (process-mask collectable))
(format #t "collectable ")
)
(if (= (logand (process-mask projectile) s5-0) (process-mask projectile))
(format #t "projectile ")
)
(if (= (logand s5-0 (process-mask sleep-code)) (process-mask sleep-code))
(format #t "sleep-code ")
)
(if (= (logand s5-0 (process-mask actor-pause)) (process-mask actor-pause))
(format #t "actor-pause ")
)
(if (= (logand (process-mask metalhead) s5-0) (shl #x8000 16))
(format #t "metalhead ")
)
(if (= (logand (process-mask bot) s5-0) (process-mask bot))
(format #t "bot ")
)
(if (= (logand (process-mask vehicle) s5-0) (process-mask vehicle))
(format #t "vehicle ")
)
(if (= (logand (process-mask enemy) s5-0) (process-mask enemy))
(format #t "enemy ")
)
(if (= (logand (process-mask entity) s5-0) (process-mask entity))
(format #t "entity ")
)
(if (= (logand s5-0 (process-mask heap-shrunk)) (process-mask heap-shrunk))
(format #t "heap-shrunk ")
)
(if (= (logand (process-mask sidekick) s5-0) (process-mask sidekick))
(format #t "sidekick ")
)
(if (= (logand s5-0 (process-mask going)) (process-mask going))
(format #t "going ")
)
(if (= (logand s5-0 (process-mask execute)) (process-mask execute))
(format #t "execute ")
)
(if (= (logand (process-mask civilian) s5-0) (process-mask civilian))
(format #t "civilian ")
)
(if (= (logand (process-mask death) s5-0) (process-mask death))
(format #t "death ")
)
(if (= (logand (process-mask guard) s5-0) (process-mask guard))
(format #t "guard ")
)
(if (= (logand s5-0 (process-mask no-kill)) (process-mask no-kill))
(format #t "no-kill ")
)
(if (= (logand (process-mask kg-robot) s5-0) (process-mask kg-robot))
(format #t "kg-robot ")
)
(if (= (logand (process-mask platform) s5-0) (process-mask platform))
(format #t "platform ")
)
(if (= (logand s5-0 (process-mask freeze)) (process-mask freeze))
(format #t "freeze ")
)
(if (= (logand s5-0 (process-mask sleep)) (process-mask sleep))
(format #t "sleep ")
)
(if (= (logand s5-0 (process-mask progress)) (process-mask progress))
(format #t "progress ")
)
(if (= (logand s5-0 (process-mask menu)) (process-mask menu))
(format #t "menu ")
)
(if (= (logand (process-mask camera) s5-0) (process-mask camera))
(format #t "camera ")
)
(if (= (logand (process-mask ambient) s5-0) (process-mask ambient))
(format #t "ambient ")
)
(if (= (logand s5-0 (process-mask dark-effect)) (process-mask dark-effect))
(format #t "dark-effect ")
)
(if (= (logand (process-mask crate) s5-0) (process-mask crate))
(format #t "crate ")
)
(if (= (logand s5-0 (process-mask kernel-run)) (process-mask kernel-run))
(format #t "kernel-run ")
)
(if (= (logand s5-0 (process-mask movie)) (process-mask movie))
(format #t "movie ")
)
(if (= (logand s5-0 (process-mask pause)) (process-mask pause))
(format #t "pause ")
)
)
(format #t ")~%")
(format #t "~1Tclock: ~A~%" (-> this clock))
(format #t "~1Tparent: #x~X~%" (-> this parent))
(format #t "~1Tbrother: #x~X~%" (-> this brother))
(format #t "~1Tchild: #x~X~%" (-> this child))
(format #t "~1Tppointer: #x~X~%" (-> this ppointer))
(format #t "~1Tself: ~A~%" (-> this self))
(label cfg-68)
this
)
;; definition of type dead-pool-heap-rec
(deftype dead-pool-heap-rec (structure)
((process process)
(prev dead-pool-heap-rec)
(next dead-pool-heap-rec)
)
:pack-me
)
;; definition for method 3 of type dead-pool-heap-rec
(defmethod inspect ((this dead-pool-heap-rec))
(when (not this)
(set! this this)
(goto cfg-4)
)
(format #t "[~8x] ~A~%" this 'dead-pool-heap-rec)
(format #t "~1Tprocess: ~A~%" (-> this process))
(format #t "~1Tprev: #<dead-pool-heap-rec @ #x~X>~%" (-> this prev))
(format #t "~1Tnext: #<dead-pool-heap-rec @ #x~X>~%" (-> this next))
(label cfg-4)
this
)
;; definition of type dead-pool-heap
(deftype dead-pool-heap (dead-pool)
((allocated-length int32)
(compact-time uint32)
(compact-count-targ uint32)
(compact-count uint32)
(fill-percent float)
(first-gap dead-pool-heap-rec)
(first-shrink dead-pool-heap-rec)
(heap kheap :inline)
(alive-list dead-pool-heap-rec :inline)
(last dead-pool-heap-rec :overlay-at (-> alive-list prev))
(dead-list dead-pool-heap-rec :inline)
(process-list dead-pool-heap-rec :inline :dynamic)
)
(:methods
(new (symbol type string int int) _type_)
(init (_type_ symbol int) none)
(compact (dead-pool-heap int) none)
(shrink-heap (dead-pool-heap process) dead-pool-heap)
(churn (dead-pool-heap int) none)
(memory-used (_type_) int)
(memory-total (_type_) int)
(memory-free (dead-pool-heap) int)
(compact-time (dead-pool-heap) uint)
(gap-size (dead-pool-heap dead-pool-heap-rec) int)
(gap-location (dead-pool-heap dead-pool-heap-rec) pointer)
(find-gap (dead-pool-heap dead-pool-heap-rec) dead-pool-heap-rec)
(find-gap-by-size (dead-pool-heap int) dead-pool-heap-rec)
)
)
;; definition for method 3 of type dead-pool-heap
(defmethod inspect ((this dead-pool-heap))
(when (not this)
(set! this this)
(goto cfg-68)
)
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~1Tname: ~A~%" (-> this name))
(format #t "~1Tmask: #x~X : (process-mask " (-> this mask))
(let ((s5-0 (-> this mask)))
(if (= (logand s5-0 (process-mask process-tree)) (process-mask process-tree))
(format #t "process-tree ")
)
(if (= (logand s5-0 (process-mask target)) (process-mask target))
(format #t "target ")
)
(if (= (logand (process-mask collectable) s5-0) (process-mask collectable))
(format #t "collectable ")
)
(if (= (logand (process-mask projectile) s5-0) (process-mask projectile))
(format #t "projectile ")
)
(if (= (logand s5-0 (process-mask sleep-code)) (process-mask sleep-code))
(format #t "sleep-code ")
)
(if (= (logand s5-0 (process-mask actor-pause)) (process-mask actor-pause))
(format #t "actor-pause ")
)
(if (= (logand (process-mask metalhead) s5-0) (shl #x8000 16))
(format #t "metalhead ")
)
(if (= (logand (process-mask bot) s5-0) (process-mask bot))
(format #t "bot ")
)
(if (= (logand (process-mask vehicle) s5-0) (process-mask vehicle))
(format #t "vehicle ")
)
(if (= (logand (process-mask enemy) s5-0) (process-mask enemy))
(format #t "enemy ")
)
(if (= (logand (process-mask entity) s5-0) (process-mask entity))
(format #t "entity ")
)
(if (= (logand s5-0 (process-mask heap-shrunk)) (process-mask heap-shrunk))
(format #t "heap-shrunk ")
)
(if (= (logand (process-mask sidekick) s5-0) (process-mask sidekick))
(format #t "sidekick ")
)
(if (= (logand s5-0 (process-mask going)) (process-mask going))
(format #t "going ")
)
(if (= (logand s5-0 (process-mask execute)) (process-mask execute))
(format #t "execute ")
)
(if (= (logand (process-mask civilian) s5-0) (process-mask civilian))
(format #t "civilian ")
)
(if (= (logand (process-mask death) s5-0) (process-mask death))
(format #t "death ")
)
(if (= (logand (process-mask guard) s5-0) (process-mask guard))
(format #t "guard ")
)
(if (= (logand s5-0 (process-mask no-kill)) (process-mask no-kill))
(format #t "no-kill ")
)
(if (= (logand (process-mask kg-robot) s5-0) (process-mask kg-robot))
(format #t "kg-robot ")
)
(if (= (logand (process-mask platform) s5-0) (process-mask platform))
(format #t "platform ")
)
(if (= (logand s5-0 (process-mask freeze)) (process-mask freeze))
(format #t "freeze ")
)
(if (= (logand s5-0 (process-mask sleep)) (process-mask sleep))
(format #t "sleep ")
)
(if (= (logand s5-0 (process-mask progress)) (process-mask progress))
(format #t "progress ")
)
(if (= (logand s5-0 (process-mask menu)) (process-mask menu))
(format #t "menu ")
)
(if (= (logand (process-mask camera) s5-0) (process-mask camera))
(format #t "camera ")
)
(if (= (logand (process-mask ambient) s5-0) (process-mask ambient))
(format #t "ambient ")
)
(if (= (logand s5-0 (process-mask dark-effect)) (process-mask dark-effect))
(format #t "dark-effect ")
)
(if (= (logand (process-mask crate) s5-0) (process-mask crate))
(format #t "crate ")
)
(if (= (logand s5-0 (process-mask kernel-run)) (process-mask kernel-run))
(format #t "kernel-run ")
)
(if (= (logand s5-0 (process-mask movie)) (process-mask movie))
(format #t "movie ")
)
(if (= (logand s5-0 (process-mask pause)) (process-mask pause))
(format #t "pause ")
)
)
(format #t ")~%")
(format #t "~1Tclock: ~A~%" (-> this clock))
(format #t "~1Tparent: #x~X~%" (-> this parent))
(format #t "~1Tbrother: #x~X~%" (-> this brother))
(format #t "~1Tchild: #x~X~%" (-> this child))
(format #t "~1Tppointer: #x~X~%" (-> this ppointer))
(format #t "~1Tself: ~A~%" (-> this self))
(format #t "~1Tallocated-length: ~D~%" (-> this allocated-length))
(format #t "~1Tcompact-time: ~D~%" (-> this compact-time))
(format #t "~1Tcompact-count-targ: ~D~%" (-> this compact-count-targ))
(format #t "~1Tcompact-count: ~D~%" (-> this compact-count))
(format #t "~1Tfill-percent: ~f~%" (-> this fill-percent))
(format #t "~1Tfirst-gap: #<dead-pool-heap-rec @ #x~X>~%" (-> this first-gap))
(format #t "~1Tfirst-shrink: #<dead-pool-heap-rec @ #x~X>~%" (-> this first-shrink))
(format #t "~1Theap: #<kheap @ #x~X>~%" (-> this heap))
(format #t "~1Talive-list: #<dead-pool-heap-rec @ #x~X>~%" (-> this alive-list))
(format #t "~1Tlast: #<dead-pool-heap-rec @ #x~X>~%" (-> this alive-list prev))
(format #t "~1Tdead-list: #<dead-pool-heap-rec @ #x~X>~%" (-> this dead-list))
(format #t "~1Tprocess-list[0] @ #x~X~%" (-> this process-list))
(label cfg-68)
this
)
;; definition of type catch-frame
(deftype catch-frame (stack-frame)
((sp int32)
(ra int32)
(freg float 10)
(rreg uint128 7)
)
(:methods
(new (symbol type symbol function (pointer uint64)) object)
)
)
;; definition for method 3 of type catch-frame
(defmethod inspect ((this catch-frame))
(when (not this)
(set! this this)
(goto cfg-4)
)
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~1Tname: ~A~%" (-> this name))
(format #t "~1Tnext: ~A~%" (-> this next))
(format #t "~1Tsp: #x~X~%" (-> this sp))
(format #t "~1Tra: #x~X~%" (-> this ra))
(format #t "~1Tfreg[6] @ #x~X~%" (-> this freg))
(format #t "~1Trreg[8] @ #x~X~%" (&-> this freg 7))
(label cfg-4)
this
)
;; definition of type protect-frame
(deftype protect-frame (stack-frame)
((exit (function object))
)
(:methods
(new (symbol type (function object)) protect-frame)
)
)
;; definition for method 3 of type protect-frame
(defmethod inspect ((this protect-frame))
(when (not this)
(set! this this)
(goto cfg-4)
)
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~1Tname: ~A~%" (-> this name))
(format #t "~1Tnext: ~A~%" (-> this next))
(format #t "~1Texit: ~A~%" (-> this exit))
(label cfg-4)
this
)
;; definition of type handle
(deftype handle (uint64)
((process (pointer process) :offset 0 :size 32)
(pid int32 :offset 32 :size 32)
(u64 uint64 :offset 0 :size 64)
)
)
;; definition for method 3 of type handle
(defmethod inspect ((this handle))
(when (not this)
(set! this this)
(goto cfg-4)
)
(format #t "[~8x] ~A~%" this 'handle)
(format #t "~1Tprocess: #x~X~%" (-> this process))
(format #t "~1Tpid: ~D~%" (-> this pid))
(label cfg-4)
this
)
;; definition for method 2 of type handle
(defmethod print ((this handle))
(if (nonzero? this)
(format #t "#<handle :process ~A :pid ~D>" (handle->process this) (-> this pid))
(format #t "#<handle :process 0 :pid 0>")
)
this
)
;; definition of type state
(deftype state (protect-frame)
((parent state)
(code function)
(trans (function object))
(post function)
(enter function)
(event (function process int symbol event-message-block object))
)
(:methods
(new (symbol type symbol function (function object) function (function object) (function process int symbol event-message-block object)) _type_)
)
)
;; definition for method 3 of type state
(defmethod inspect ((this state))
(when (not this)
(set! this this)
(goto cfg-4)
)
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~1Tname: ~A~%" (-> this name))
(format #t "~1Tnext: ~A~%" (-> this next))
(format #t "~1Texit: ~A~%" (-> this exit))
(format #t "~1Tparent: ~A~%" (-> this parent))
(format #t "~1Tcode: ~A~%" (-> this code))
(format #t "~1Ttrans: ~A~%" (-> this trans))
(format #t "~1Tpost: ~A~%" (-> this post))
(format #t "~1Tenter: ~A~%" (-> this enter))
(format #t "~1Tevent: ~A~%" (-> this event))
(label cfg-4)
this
)
;; definition of type event-message-block
(deftype event-message-block (structure)
((to-handle handle)
(to (pointer process) :overlay-at to-handle)
(from-handle handle)
(from (pointer process) :overlay-at from-handle)
(param uint64 6)
(message symbol)
(num-params int32)
)
)
;; definition for method 3 of type event-message-block
(defmethod inspect ((this event-message-block))
(when (not this)
(set! this this)
(goto cfg-8)
)
(format #t "[~8x] ~A~%" this 'event-message-block)
(format #t "~1Tto-handle: ~D~%" (-> this to-handle))
(format #t "~1Tto: ~A~%" (ppointer->process (-> this to)))
(format #t "~1Tfrom-handle: ~D~%" (-> this from-handle))
(format #t "~1Tfrom: ~A~%" (ppointer->process (-> this from)))
(format #t "~1Tparam[6] @ #x~X~%" (-> this param))
(format #t "~1Tmessage: ~A~%" (-> this message))
(format #t "~1Tnum-params: ~D~%" (-> this num-params))
(label cfg-8)
this
)
;; definition of type event-message-block-array
(deftype event-message-block-array (inline-array-class)
((data event-message-block :inline :dynamic)
)
(:methods
(send-all! (_type_) none)
)
)
;; definition for method 3 of type event-message-block-array
(defmethod inspect ((this event-message-block-array))
(when (not this)
(set! this this)
(goto cfg-4)
)
(format #t "[~8x] ~A~%" this (-> this type))
(format #t "~1Tlength: ~D~%" (-> this length))
(format #t "~1Tallocated-length: ~D~%" (-> this allocated-length))
(format #t "~1Tdata[0] @ #x~X~%" (-> this data))
(label cfg-4)
this
)
;; failed to figure out what this is:
(set! (-> event-message-block-array heap-base) (the-as uint 80))
;; definition of type sql-result
(deftype sql-result (array)
((sql-data object :dynamic :offset 16)
)
(:methods
(new (symbol type int) _type_)
)
)
;; definition for method 0 of type sql-result
(defmethod new sql-result ((allocation symbol) (type-to-make type) (num-elts int))
(let ((v0-0 (object-new allocation type-to-make (the-as int (+ (-> type-to-make size) (* num-elts 4))))))
(set! (-> v0-0 allocated-length) num-elts)
(set! (-> v0-0 content-type) (the-as type 'error))
v0-0
)
)
;; definition for method 2 of type sql-result
(defmethod print ((this sql-result))
(format #t "#(~A" (-> this content-type))
(dotimes (s5-0 (-> this length))
(format #t " ~A" (-> this sql-data s5-0))
)
(format #t ")")
this
)
;; definition for symbol *sql-result*, type sql-result
(define *sql-result* (the-as sql-result #f))
;; failed to figure out what this is:
0
test/decompiler/reference/jak3/kernel/gkernel_REF.gc
Generated Vendored
+1811
View File
File diff suppressed because it is too large Load Diff
test/decompiler/reference/jak3/kernel/gstate_REF.gc
Generated Vendored
+196
View File
@@ -0,0 +1,196 @@
;;-*-Lisp-*-
(in-package goal)
;; definition for method 0 of type state
(defmethod new state ((allocation symbol)
(type-to-make type)
(arg0 symbol)
(arg1 function)
(arg2 (function object))
(arg3 function)
(arg4 (function object))
(arg5 (function process int symbol event-message-block object))
)
(let ((v0-0 (object-new allocation type-to-make (the-as int (-> type-to-make size)))))
(set! (-> v0-0 name) arg0)
(set! (-> v0-0 next) #f)
(set! (-> v0-0 parent) #f)
(set! (-> v0-0 exit) arg4)
(set! (-> v0-0 code) arg1)
(set! (-> v0-0 trans) arg2)
(set! (-> v0-0 post) #f)
(set! (-> v0-0 enter) arg3)
(set! (-> v0-0 event) arg5)
v0-0
)
)
;; definition for function inherit-state
(defun inherit-state ((arg0 state) (arg1 state))
(set! (-> arg0 parent) (-> arg1 parent))
(set! (-> arg0 exit) (-> arg1 exit))
(set! (-> arg0 code) (-> arg1 code))
(set! (-> arg0 trans) (-> arg1 trans))
(set! (-> arg0 post) (-> arg1 post))
(set! (-> arg0 enter) (-> arg1 enter))
(set! (-> arg0 event) (-> arg1 event))
arg0
)
;; definition for method 2 of type state
(defmethod print ((this state))
(format #t "#<~A ~A @ #x~X>" (-> this type) (-> this name) this)
this
)
;; definition for function state-type?
(defun state-type? ((arg0 state) (arg1 symbol))
(let ((v1-0 arg0))
(while v1-0
(if (= (-> v1-0 name) arg1)
(return #t)
)
(set! v1-0 (-> v1-0 parent))
)
)
#f
)
;; definition for function enter-state
;; ERROR: Unsupported inline assembly instruction kind - [lwu sp, 28(v1)]
;; ERROR: Unsupported inline assembly instruction kind - [lw ra, return-from-thread-dead(s7)]
;; ERROR: Unsupported inline assembly instruction kind - [jr t9]
;; ERROR: Unsupported inline assembly instruction kind - [sw v1, 0(sp)]
(defun enter-state ((arg0 object) (arg1 object) (arg2 object) (arg3 object) (arg4 object) (arg5 object))
(local-vars (s7-0 none) (sp-0 int) (ra-0 int))
(with-pp
(logclear! (-> pp mask) (process-mask sleep sleep-code))
(logior! (-> pp mask) (process-mask going))
(cond
((= (-> pp status) 'initialize)
(set! (-> pp trans-hook) #f)
(set-to-run (-> pp main-thread) enter-state arg0 arg1 arg2 arg3 arg4 arg5)
(set! (-> pp status) 'initialize-go)
(throw 'initialize #t)
#t
)
((!= (-> *kernel-context* current-process) pp)
(let ((s0-0 (-> pp status)))
(set! (-> pp trans-hook) #f)
(set-to-run (-> pp main-thread) enter-state arg0 arg1 arg2 arg3 arg4 arg5)
(set! (-> pp status) s0-0)
)
#t
)
((= (-> pp main-thread) (-> pp top-thread))
(set! (-> pp prev-state) (-> pp state))
(set! (-> pp state) (-> pp next-state))
(let ((s0-1 (-> pp stack-frame-top)))
(while s0-1
(case (-> s0-1 type)
((protect-frame state)
((-> (the-as protect-frame s0-1) exit))
)
)
(set! s0-1 (-> s0-1 next))
)
)
(logclear! (-> pp mask) (process-mask going))
(let ((s0-2 (-> pp state)))
(set! (-> pp event-hook) (-> s0-2 event))
(if (-> s0-2 exit)
(set! (-> pp stack-frame-top) s0-2)
(set! (-> pp stack-frame-top) #f)
)
(set! (-> pp post-hook) (-> s0-2 post))
(set! (-> pp trans-hook) (-> s0-2 trans))
(let ((t9-4 (-> s0-2 enter)))
(if t9-4
((the-as (function object object object object object object none) t9-4) arg0 arg1 arg2 arg3 arg4 arg5)
)
)
(let ((t9-5 (-> s0-2 trans)))
(if t9-5
(t9-5)
)
)
(let ((v1-29 (-> pp main-thread)))
(.lwu sp-0 28 v1-29)
)
(let ((t9-6 (-> s0-2 code)))
(.lw ra-0 return-from-thread-dead s7-0)
(.jr t9-6)
)
)
arg4
)
(else
(set! (-> pp trans-hook) #f)
(set-to-run (-> pp main-thread) enter-state arg0 arg1 arg2 arg3 arg4 arg5)
(when (!= (-> pp top-thread name) 'post)
(let ((v1-32 return-from-thread))
(.sw v1-32 0 (the-as none sp-0))
)
)
#t
)
)
)
)
;; failed to figure out what this is:
(kmemopen global "event-queue")
;; failed to figure out what this is:
(let ((v1-4 (new 'global 'event-message-block-array 64)))
(set! (-> v1-4 length) 0)
(set! *event-queue* v1-4)
)
;; failed to figure out what this is:
(kmemclose)
;; definition for function send-event-function
(defun send-event-function ((arg0 process-tree) (arg1 event-message-block))
(with-pp
(when (and arg0 (!= (-> arg0 type) process-tree) (-> (the-as process arg0) event-hook) (-> arg1 from))
(let ((gp-0 pp))
(set! pp (the-as process arg0))
(let ((v0-0 ((-> (the-as process arg0) event-hook) (-> arg1 from 0) (-> arg1 num-params) (-> arg1 message) arg1)))
(set! pp gp-0)
v0-0
)
)
)
)
)
;; definition for method 14 of type event-message-block-array
;; WARN: Return type mismatch int vs none.
(defmethod send-all! ((this event-message-block-array))
(dotimes (s5-0 (-> this length))
(let* ((a1-0 (-> this data s5-0))
(a0-2 (handle->process (-> a1-0 to-handle)))
)
(if (and a0-2 (handle->process (-> a1-0 from-handle)))
(send-event-function a0-2 a1-0)
)
)
)
(set! (-> this length) 0)
0
(none)
)
;; definition for function looping-code
;; WARN: new jak 2 until loop case, check carefully
(defun looping-code ()
(until #f
(suspend)
)
#f
)
test/decompiler/reference/jak3/kernel/gstring_REF.gc
Generated Vendored
+835
View File
@@ -0,0 +1,835 @@
;;-*-Lisp-*-
(in-package goal)
;; definition for method 4 of type string
(defmethod length ((this string))
(let ((v1-0 (-> this data)))
(while (nonzero? (-> v1-0 0))
(nop!)
(nop!)
(nop!)
(set! v1-0 (&-> v1-0 1))
)
(&- v1-0 (the-as uint (-> this data)))
)
)
;; definition for method 5 of type string
(defmethod asize-of ((this string))
(+ (-> this allocated-length) 1 (-> string size))
)
;; definition for function copy-string<-string
(defun copy-string<-string ((dst string) (src string))
"Copy a string. No bounds check. Writes null terminator."
(let ((v1-0 (-> dst data)))
(let ((a1-1 (-> src data)))
(while (nonzero? (-> a1-1 0))
(set! (-> v1-0 0) (-> a1-1 0))
(set! v1-0 (&-> v1-0 1))
(set! a1-1 (&-> a1-1 1))
)
)
(set! (-> v1-0 0) (the-as uint 0))
)
dst
)
;; definition for method 0 of type string
(defmethod new string ((allocation symbol) (type-to-make type) (arg0 int) (arg1 string))
(cond
(arg1
(let* ((s2-1 (max (length arg1) arg0))
(a0-4 (object-new allocation type-to-make (+ s2-1 1 (-> type-to-make size))))
)
(set! (-> a0-4 allocated-length) s2-1)
(copy-string<-string a0-4 arg1)
)
)
(else
(let ((v0-2 (object-new allocation type-to-make (+ arg0 1 (-> type-to-make size)))))
(set! (-> v0-2 allocated-length) arg0)
v0-2
)
)
)
)
;; definition for function string=
(defun string= ((a string) (b string))
"Check for string equality."
(let ((a2-0 (-> a data))
(v1-0 (-> b data))
)
(if (or (zero? a) (zero? b))
(return #f)
)
(while (and (nonzero? (-> a2-0 0)) (nonzero? (-> v1-0 0)))
(if (!= (-> a2-0 0) (-> v1-0 0))
(return #f)
)
(set! a2-0 (&-> a2-0 1))
(set! v1-0 (&-> v1-0 1))
)
(and (zero? (-> a2-0 0)) (zero? (-> v1-0 0)))
)
)
;; definition for function string-prefix=
(defun string-prefix= ((prefix string) (str string))
"Check if a string starts with a given string."
(let ((v1-0 (-> prefix data)))
(let ((a2-0 (-> str data)))
(if (or (zero? prefix) (zero? str))
(return #f)
)
(while (and (nonzero? (-> v1-0 0)) (nonzero? (-> a2-0 0)))
(if (!= (-> v1-0 0) (-> a2-0 0))
(return #f)
)
(set! v1-0 (&-> v1-0 1))
(set! a2-0 (&-> a2-0 1))
)
)
(zero? (-> v1-0 0))
)
)
;; definition for function charp-prefix=
(defun charp-prefix= ((prefix (pointer uint8)) (str (pointer uint8)))
"Check if a c-string starts with a given c-string."
(while (and (nonzero? (-> prefix 0)) (nonzero? (-> str 0)))
(if (!= (-> prefix 0) (-> str 0))
(return #f)
)
(set! prefix (&-> prefix 1))
(set! str (&-> str 1))
)
(zero? (-> prefix 0))
)
;; definition for function string-suffix=
(defun string-suffix= ((suffix string) (str string))
"Check if a string ends with a given string."
(let ((s5-0 (-> suffix data))
(gp-0 (-> str data))
)
(if (or (zero? suffix) (zero? str))
(return #f)
)
(let ((s4-0 (length suffix))
(v1-5 (length str))
)
(if (< s4-0 v1-5)
(return #f)
)
(let ((v1-7 (&+ s5-0 (- s4-0 v1-5))))
(while (and (nonzero? (-> v1-7 0)) (nonzero? (-> gp-0 0)))
(if (!= (-> v1-7 0) (-> gp-0 0))
(return #f)
)
(set! v1-7 (&-> v1-7 1))
(set! gp-0 (&-> gp-0 1))
)
(zero? (-> v1-7 0))
)
)
)
)
;; definition for function string-position
(defun string-position ((substr string) (base-str string))
"Find the point where a string occurs in another. If it doesn't, return -1."
(let ((s5-0 0)
(s4-0 (-> base-str data))
)
(while (nonzero? (-> s4-0 0))
(if (charp-prefix= (-> substr data) s4-0)
(return s5-0)
)
(+! s5-0 1)
(set! s4-0 (&-> s4-0 1))
)
)
-1
)
;; definition for function string-charp=
(defun string-charp= ((a string) (b (pointer uint8)))
"Check if a string is equal to a c-string."
(let ((v1-0 (-> a data)))
(while (and (nonzero? (-> v1-0 0)) (nonzero? (-> b 0)))
(if (!= (-> v1-0 0) (-> b 0))
(return #f)
)
(set! v1-0 (&-> v1-0 1))
(set! b (&-> b 1))
)
(and (zero? (-> v1-0 0)) (zero? (-> b 0)))
)
)
;; definition for function name=
;; ERROR: function was not converted to expressions. Cannot decompile.
;; definition for function copyn-string<-charp
(defun copyn-string<-charp ((dst string) (src (pointer uint8)) (num-chars int))
"Copy part of a c-string to a string. Writes null terminator after num-chars."
(let ((v1-0 (-> dst data)))
(dotimes (a3-0 num-chars)
(set! (-> v1-0 0) (-> src 0))
(set! v1-0 (&-> v1-0 1))
(set! src (&-> src 1))
)
(set! (-> v1-0 0) (the-as uint 0))
)
dst
)
;; definition for function string<-charp
(defun string<-charp ((dst string) (src (pointer uint8)))
"Copy a c-string to a string. Writes the null terminator."
(let ((v1-0 (-> dst data)))
(while (nonzero? (-> src 0))
(set! (-> v1-0 0) (-> src 0))
(set! v1-0 (&-> v1-0 1))
(set! src (&-> src 1))
)
(set! (-> v1-0 0) (the-as uint 0))
)
dst
)
;; definition for function charp<-string
(defun charp<-string ((dst (pointer uint8)) (src string))
"Copy a string to a c-string. Writes the null terminator."
(let ((v1-0 (-> src data)))
(while (nonzero? (-> v1-0 0))
(set! (-> dst 0) (-> v1-0 0))
(set! dst (&-> dst 1))
(set! v1-0 (&-> v1-0 1))
)
)
(set! (-> dst 0) (the-as uint 0))
0
)
;; definition for function copyn-charp<-string
;; WARN: Return type mismatch int vs none.
(defun copyn-charp<-string ((dst (pointer uint8)) (src string) (len int))
"Copy part of a string to a c-string. Writes null terminator, repeatedly, to reach the given length.
If the source is longer than the length, the null terminator is still included."
(let ((v1-0 (-> src data)))
(while (and (nonzero? (-> v1-0 0)) (< 1 len))
(set! (-> dst 0) (-> v1-0 0))
(set! dst (&-> dst 1))
(set! v1-0 (&-> v1-0 1))
(set! len (+ len -1))
)
)
(while (> len 0)
(set! (-> dst 0) (the-as uint 0))
(set! dst (&-> dst 1))
(set! len (+ len -1))
)
0
(none)
)
;; definition for function copy-charp<-charp
(defun copy-charp<-charp ((dst (pointer uint8)) (src (pointer uint8)))
"C-string copy, writes null terminator."
(while (nonzero? (-> src 0))
(set! (-> dst 0) (-> src 0))
(set! dst (&-> dst 1))
(set! src (&-> src 1))
)
(set! (-> dst 0) (the-as uint 0))
dst
)
;; definition for function cat-string<-string
(defun cat-string<-string ((dst string) (src string))
"Append a string to another."
(let ((v1-0 (-> dst data)))
(let ((a1-1 (-> src data)))
(while (nonzero? (-> v1-0 0))
(nop!)
(nop!)
(nop!)
(set! v1-0 (&-> v1-0 1))
)
(while (nonzero? (-> a1-1 0))
(set! (-> v1-0 0) (-> a1-1 0))
(set! v1-0 (&-> v1-0 1))
(set! a1-1 (&-> a1-1 1))
)
)
(set! (-> v1-0 0) (the-as uint 0))
)
dst
)
;; definition for function catn-string<-charp
(defun catn-string<-charp ((dst string) (src (pointer uint8)) (num-chars int))
"Append part of a string to another. Writes null terminator."
(let ((v1-0 (-> dst data)))
(while (nonzero? (-> v1-0 0))
(nop!)
(nop!)
(nop!)
(set! v1-0 (&-> v1-0 1))
)
(dotimes (a3-2 num-chars)
(set! (-> v1-0 0) (-> src 0))
(set! v1-0 (&-> v1-0 1))
(set! src (&-> src 1))
)
(set! (-> v1-0 0) (the-as uint 0))
)
dst
)
;; definition for function cat-string<-string_to_charp
(defun cat-string<-string_to_charp ((dst string) (src string) (stop-ptr (pointer uint8)))
"Append part of a string to another, up to the given pointer."
(let ((v1-0 (-> src data))
(v0-0 (-> dst data))
)
(while (nonzero? (-> v0-0 0))
(nop!)
(nop!)
(nop!)
(set! v0-0 (&-> v0-0 1))
)
(while (and (>= (the-as int stop-ptr) (the-as int v1-0)) (nonzero? (-> v1-0 0)))
(set! (-> v0-0 0) (-> v1-0 0))
(set! v0-0 (&-> v0-0 1))
(set! v1-0 (&-> v1-0 1))
)
(set! (-> v0-0 0) (the-as uint 0))
v0-0
)
)
;; definition for function append-character-to-string
(defun append-character-to-string ((str string) (char uint8))
"Append a single character to a string. Writes null terminator after."
(let ((v1-0 (-> str data)))
(while (nonzero? (-> v1-0 0))
(nop!)
(nop!)
(nop!)
(set! v1-0 (&-> v1-0 1))
)
(set! (-> v1-0 0) (the-as uint char))
(set! (-> v1-0 1) (the-as uint 0))
)
0
0
)
;; definition for function charp-basename
(defun charp-basename ((str (pointer uint8)))
"Strip the directory and suffix from a c-string."
(let ((v1-0 str))
(while (nonzero? (-> v1-0 0))
(set! v1-0 (&-> v1-0 1))
)
(while (< (the-as int str) (the-as int v1-0))
(set! v1-0 (&-> v1-0 -1))
(if (or (= (-> v1-0 0) 47) (= (-> v1-0 0) 92))
(return (&-> v1-0 1))
)
)
)
str
)
;; definition for function clear
(defun clear ((str string))
"Set string to the empty string."
(set! (-> str data 0) (the-as uint 0))
str
)
;; definition for function string<?
(defun string<? ((a string) (b string))
"Slightly incorrect ordering of strings."
(let ((s4-1 (min (length a) (length b))))
(dotimes (v1-4 s4-1)
(cond
((< (-> a data v1-4) (-> b data v1-4))
(return #t)
)
((< (-> b data v1-4) (-> a data v1-4))
(return #f)
)
)
)
)
#f
)
;; definition for function string>?
(defun string>? ((a string) (b string))
"Slightly incorrect ordering of strings."
(let ((s4-1 (min (length a) (length b))))
(dotimes (v1-4 s4-1)
(cond
((< (-> a data v1-4) (-> b data v1-4))
(return #f)
)
((< (-> b data v1-4) (-> a data v1-4))
(return #t)
)
)
)
)
#f
)
;; definition for function string<=?
(defun string<=? ((a string) (b string))
"Slightly incorrect ordering of strings."
(let ((s4-1 (min (length a) (length b))))
(dotimes (v1-4 s4-1)
(cond
((< (-> a data v1-4) (-> b data v1-4))
(return #t)
)
((< (-> b data v1-4) (-> a data v1-4))
(return #f)
)
)
)
)
#t
)
;; definition for function string>=?
(defun string>=? ((a string) (b string))
"Slightly incorrect ordering of strings."
(let ((s4-1 (min (length a) (length b))))
(dotimes (v1-4 s4-1)
(cond
((< (-> a data v1-4) (-> b data v1-4))
(return #f)
)
((< (-> b data v1-4) (-> a data v1-4))
(return #t)
)
)
)
)
#t
)
;; definition for symbol *string-tmp-str*, type string
(define *string-tmp-str* (new 'global 'string 128 (the-as string #f)))
;; definition for function string-skip-to-char
(defun string-skip-to-char ((arg0 (pointer uint8)) (arg1 uint))
"Advance to the given character."
(while (and (nonzero? (-> arg0 0)) (!= (-> arg0 0) arg1))
(set! arg0 (&-> arg0 1))
)
arg0
)
;; definition for function string-cat-to-last-char
(defun string-cat-to-last-char ((arg0 string) (arg1 string) (arg2 uint))
"Append append-str to end of base-str, up to the last occurance of char"
(let ((s4-0 (&-> (the-as (pointer uint8) arg1) 3)))
(let ((v1-0 (string-skip-to-char (-> arg1 data) arg2)))
(when (= (-> v1-0 0) arg2)
(until (!= (-> v1-0 0) arg2)
(set! s4-0 v1-0)
(set! v1-0 (string-skip-to-char (&-> v1-0 1) arg2))
)
)
)
(cat-string<-string_to_charp arg0 arg1 s4-0)
)
)
;; definition for function string-skip-whitespace
(defun string-skip-whitespace ((arg0 (pointer uint8)))
"Jump over whitespace chars."
(while (and (nonzero? (-> arg0 0)) (or (= (-> arg0 0) 32) (= (-> arg0 0) 9) (= (-> arg0 0) 13) (= (-> arg0 0) 10)))
(set! arg0 (&-> arg0 1))
)
arg0
)
;; definition for function string-suck-up!
(defun string-suck-up! ((arg0 string) (arg1 (pointer uint8)))
"Move the string forward so the pointer is now at the beginning."
(when (!= arg1 (-> arg0 data))
(let ((v1-2 (-> arg0 data)))
(while (nonzero? (-> arg1 0))
(set! (-> v1-2 0) (-> arg1 0))
(set! v1-2 (&-> v1-2 1))
(set! arg1 (&-> arg1 1))
)
(set! (-> v1-2 0) (the-as uint 0))
)
0
)
#f
)
;; definition for function string-strip-leading-whitespace!
(defun string-strip-leading-whitespace! ((arg0 string))
"Strip leading whitespace."
(let ((a1-0 (string-skip-whitespace (-> arg0 data))))
(string-suck-up! arg0 a1-0)
)
#f
)
;; definition for function string-strip-trailing-whitespace!
(defun string-strip-trailing-whitespace! ((arg0 string))
"String trailing whitespace."
(when (nonzero? (length arg0))
(let ((v1-6 (&+ (-> arg0 data) (+ (length arg0) -1))))
(while (and (>= (the-as int v1-6) (the-as int (-> arg0 data)))
(or (= (-> v1-6 0) 32) (= (-> v1-6 0) 9) (= (-> v1-6 0) 13) (= (-> v1-6 0) 10))
)
(set! v1-6 (&-> v1-6 -1))
)
(set! (-> v1-6 1) (the-as uint 0))
)
0
)
#f
)
;; definition for function string-strip-whitespace!
(defun string-strip-whitespace! ((arg0 string))
"Strip whitespace from the beginning and end of a string"
(string-strip-trailing-whitespace! arg0)
(string-strip-leading-whitespace! arg0)
#f
)
;; definition for function string-upcase
;; WARN: Return type mismatch string vs none.
(defun string-upcase ((arg0 string) (arg1 string) (arg2 symbol))
"Uppercase characters. If convert-dash is set, - will be uppercased to _"
(let* ((a0-1 (-> arg0 data))
(t0-0 (the-as int (-> a0-1 0)))
(a3-0 1)
(v1-0 0)
)
(while (nonzero? (the-as uint t0-0))
(cond
((and (>= (the-as uint t0-0) (the-as uint 97)) (>= (the-as uint 122) (the-as uint t0-0)))
(set! t0-0 (the-as int (+ (the-as uint t0-0) -32)))
)
((and arg2 (= (the-as uint t0-0) 45))
(set! t0-0 95)
)
)
(set! (-> arg1 data v1-0) (the-as uint t0-0))
(set! t0-0 (the-as int (-> a0-1 a3-0)))
(+! a3-0 1)
(+! v1-0 1)
)
(set! (-> arg1 data v1-0) (the-as uint 0))
)
0
(none)
)
;; definition for function string-get-arg!!
(defun string-get-arg!! ((arg0 string) (arg1 string))
(let ((s4-0 (string-skip-whitespace (-> arg1 data))))
(cond
((= (-> s4-0 0) 34)
(let ((s4-1 (&-> s4-0 1)))
(let ((v1-3 s4-1))
(while (and (nonzero? (-> s4-1 0)) (!= (-> s4-1 0) 34))
(set! s4-1 (&-> s4-1 1))
)
(copyn-string<-charp arg0 v1-3 (&- s4-1 (the-as uint v1-3)))
)
(if (= (-> s4-1 0) 34)
(set! s4-1 (&-> s4-1 1))
)
(let ((a1-3 (string-skip-whitespace s4-1)))
(string-suck-up! arg1 a1-3)
)
)
(return #t)
)
((nonzero? (-> s4-0 0))
(let ((v1-11 s4-0))
(while (and (nonzero? (-> s4-0 0)) (!= (-> s4-0 0) 32) (!= (-> s4-0 0) 9) (!= (-> s4-0 0) 13) (!= (-> s4-0 0) 10))
(set! s4-0 (&-> s4-0 1))
)
(copyn-string<-charp arg0 v1-11 (&- s4-0 (the-as uint v1-11)))
)
(let ((a1-9 (string-skip-whitespace s4-0)))
(string-suck-up! arg1 a1-9)
)
(return #t)
)
)
)
#f
)
;; definition for function string->int
(defun string->int ((arg0 string))
"Convert string to int."
(let ((a0-1 (-> arg0 data))
(v0-0 0)
(v1-0 #f)
)
(cond
((= (-> a0-1 0) 35)
(let ((a0-2 (&-> a0-1 1)))
(cond
((or (= (-> a0-2 0) 120) (= (-> a0-2 0) 88))
(let ((a0-3 (&-> a0-2 1)))
(when (= (-> a0-3 1) 45)
(set! v1-0 #t)
(set! a0-3 (&-> a0-3 1))
)
(while (or (and (>= (-> a0-3 0) (the-as uint 48)) (>= (the-as uint 57) (-> a0-3 0)))
(and (>= (-> a0-3 0) (the-as uint 65)) (>= (the-as uint 70) (-> a0-3 0)))
(and (>= (-> a0-3 0) (the-as uint 97)) (>= (the-as uint 102) (-> a0-3 0)))
)
(cond
((and (>= (-> a0-3 0) (the-as uint 65)) (>= (the-as uint 70) (-> a0-3 0)))
(set! v0-0 (the-as int (+ (-> a0-3 0) -55 (* v0-0 16))))
)
((and (>= (-> a0-3 0) (the-as uint 97)) (>= (the-as uint 102) (-> a0-3 0)))
(set! v0-0 (the-as int (+ (-> a0-3 0) -87 (* v0-0 16))))
)
(else
(set! v0-0 (the-as int (+ (-> a0-3 0) -48 (* v0-0 16))))
)
)
(set! a0-3 (&-> a0-3 1))
)
)
)
((or (= (-> a0-2 0) 98) (= (-> a0-2 0) 66))
(let ((a0-4 (&-> a0-2 1)))
(while (and (>= (-> a0-4 0) (the-as uint 48)) (>= (the-as uint 49) (-> a0-4 0)))
(set! v0-0 (the-as int (+ (-> a0-4 0) -48 (* v0-0 2))))
(set! a0-4 (&-> a0-4 1))
)
)
)
)
)
)
(else
(when (= (-> a0-1 1) 45)
(set! v1-0 #t)
(set! a0-1 (&-> a0-1 1))
)
(while (and (>= (-> a0-1 0) (the-as uint 48)) (>= (the-as uint 57) (-> a0-1 0)))
(set! v0-0 (the-as int (+ (-> a0-1 0) -48 (* 10 v0-0))))
(set! a0-1 (&-> a0-1 1))
)
)
)
(cond
(v1-0
(- v0-0)
)
(else
(empty)
v0-0
)
)
)
)
;; definition for function string->float
(defun string->float ((arg0 string))
"Convert string to float. Finally implemented!"
(let ((a0-1 (-> arg0 data))
(f0-0 0.0)
(v1-0 #f)
)
(when (= (-> a0-1 0) 45)
(set! v1-0 #t)
(set! a0-1 (&-> a0-1 1))
)
(while (and (>= (-> a0-1 0) (the-as uint 48)) (>= (the-as uint 57) (-> a0-1 0)))
(set! f0-0 (+ (* 10.0 f0-0) (the float (+ (-> a0-1 0) -48))))
(set! a0-1 (&-> a0-1 1))
)
(when (= (-> a0-1 0) 46)
(set! a0-1 (&-> a0-1 1))
(let ((a2-4 #xf4240)
(a1-12 0)
)
(while (and (>= (-> a0-1 0) (the-as uint 48)) (>= (the-as uint 57) (-> a0-1 0)))
(+! a1-12 (* (+ (-> a0-1 0) -48) (the-as uint a2-4)))
(set! a2-4 (/ a2-4 10))
(set! a0-1 (&-> a0-1 1))
)
(+! f0-0 (* 0.0000001 (the float a1-12)))
)
)
(when (= (-> a0-1 0) 101)
(let ((a1-16 (&-> a0-1 1))
(f1-5 0.0)
(a0-2 #f)
)
(cond
((= (-> a1-16 0) 45)
(set! a0-2 #t)
(set! a1-16 (&-> a1-16 1))
)
((= (-> a1-16 0) 43)
(set! a1-16 (&-> a1-16 1))
)
)
(while (and (>= (-> a1-16 0) (the-as uint 48)) (>= (the-as uint 57) (-> a1-16 0)))
(set! f1-5 (+ (* 10.0 f1-5) (the float (+ (-> a1-16 0) -48))))
(set! a1-16 (&-> a1-16 1))
)
(when (!= f1-5 0.0)
(let ((f2-6 1.0))
(cond
(a0-2
(dotimes (a0-3 (the int f1-5))
(set! f2-6 (* 0.1 f2-6))
(nop!)
(nop!)
)
)
(else
(dotimes (a0-6 (the int f1-5))
(set! f2-6 (* 10.0 f2-6))
(nop!)
(nop!)
)
)
)
(set! f0-0 (* f0-0 f2-6))
)
)
)
)
(if v1-0
(- f0-0)
f0-0
)
)
)
;; definition for function string-get-int32!!
(defun string-get-int32!! ((arg0 (pointer int32)) (arg1 string))
(cond
((string-get-arg!! *string-tmp-str* arg1)
(set! (-> arg0 0) (string->int *string-tmp-str*))
#t
)
(else
#f
)
)
)
;; definition for function string-get-float!!
(defun string-get-float!! ((arg0 (pointer float)) (arg1 string))
(cond
((string-get-arg!! *string-tmp-str* arg1)
(set! (-> arg0 0) (string->float *string-tmp-str*))
#t
)
(else
#f
)
)
)
;; definition for function string-get-flag!!
(defun string-get-flag!! ((arg0 (pointer symbol)) (arg1 string) (arg2 string) (arg3 string))
(cond
((string-get-arg!! *string-tmp-str* arg1)
(cond
((or (string= *string-tmp-str* arg2) (string= *string-tmp-str* arg3))
(set! (-> arg0 0) (string= *string-tmp-str* arg2))
#t
)
(else
#f
)
)
)
(else
#f
)
)
)
;; definition for function string-word-wrap
;; WARN: Return type mismatch int vs none.
(defun string-word-wrap ((arg0 string) (arg1 int))
"Wrap lines to specified width."
(let ((v1-0 (-> arg0 data)))
(label cfg-1)
(let ((a2-0 0)
(a0-1 0)
)
(b! #t cfg-6 :delay (nop!))
(label cfg-2)
(b! (zero? (-> v1-0 a2-0)) cfg-11 :delay (nop!))
(if (= (-> v1-0 a2-0) 32)
(set! a0-1 a2-0)
)
(+! a2-0 1)
(label cfg-6)
(b! (< a2-0 arg1) cfg-2)
(if (zero? a0-1)
(set! a0-1 a2-0)
)
(set! (-> v1-0 a0-1) (the-as uint 10))
(&+! v1-0 (+ a0-1 1))
)
)
(goto cfg-1)
(label cfg-11)
0
(none)
)
;; failed to figure out what this is:
(kmemopen global "gstring-globals")
;; definition for symbol *debug-draw-pauseable*, type symbol
(define *debug-draw-pauseable* #f)
;; definition for symbol *stdcon0*, type string
(define *stdcon0* (new 'global 'string #x4000 (the-as string #f)))
;; definition for symbol *stdcon1*, type string
(define *stdcon1* (new 'global 'string #x4000 (the-as string #f)))
;; definition for symbol *null*, type string
(define *null* (new 'global 'string 0 (the-as string #f)))
;; definition for symbol *stdcon*, type string
(define *stdcon* *stdcon0*)
;; definition for symbol *stdebug*, type string
(define *stdebug* *stdcon1*)
;; definition for symbol *temp-string*, type string
(define *temp-string* (new 'global 'string 2048 (the-as string #f)))
;; failed to figure out what this is:
(kmemclose)
test/goalc/CMakeLists.txt
+1
View File
@@ -7,6 +7,7 @@ set(GOALC_TEST_CASES
${CMAKE_CURRENT_LIST_DIR}/test_game_no_debug.cpp
${CMAKE_CURRENT_LIST_DIR}/test_goal_kernel.cpp
${CMAKE_CURRENT_LIST_DIR}/test_goal_kernel2.cpp
${CMAKE_CURRENT_LIST_DIR}/test_goal_kernel3.cpp
${CMAKE_CURRENT_LIST_DIR}/test_jak2_compiler.cpp
${CMAKE_CURRENT_LIST_DIR}/test_variables.cpp
${CMAKE_CURRENT_LIST_DIR}/test_with_game.cpp
test/goalc/framework/test_runner.cpp
+9
View File
@@ -140,6 +140,15 @@ void runtime_with_kernel_jak2() {
exec_runtime(game_options, argc, argv);
}
void runtime_with_kernel_jak3() {
constexpr int argc = 4;
const char* argv[argc] = {"", "-fakeiso", "-debug", "-nosound"};
GameLaunchOptions game_options;
game_options.disable_display = true;
game_options.game_version = GameVersion::Jak3;
exec_runtime(game_options, argc, argv);
}
void runtime_with_kernel_no_debug_segment() {
constexpr int argc = 4;
const char* argv[argc] = {"", "-fakeiso", "-debug-mem", "-nosound"};
test/goalc/framework/test_runner.h
+1
View File
@@ -51,6 +51,7 @@ void runtime_no_kernel_jak1();
void runtime_no_kernel_jak2();
void runtime_with_kernel_jak1();
void runtime_with_kernel_jak2();
void runtime_with_kernel_jak3();
void runtime_with_kernel_no_debug_segment();
void createDirIfAbsent(const std::string& path);
test/goalc/source_templates/jak3/kernel-test.gc
+227
View File
@@ -0,0 +1,227 @@
(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 #f))
(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 #f))
;; 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 check-current-proc-catch-rbx ()
;; (format 0 "last rbx = ~X~%" *last-rbx*)
(with-pp
(format 0 "PP = ~X~%" pp)
(let ((frame (-> pp stack-frame-top)))
(format 0 "FRAME0: ~A~%" frame)
(while frame
(format 0 "FRAME: ~A~%" frame)
(when (= (-> frame type) catch-frame)
(format 0 "found upcoming protect frame! ~A: ~X~%"
(-> (the catch-frame frame) name)
(-> (the catch-frame frame) rreg 0)
)
)
(set! frame (-> frame next))
)
)
)
)
(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)))
)
(when (eq? a0 (the int 0))
(format 0 "doing child proc deactivate~%")
(check-current-proc-catch-rbx)
(process-deactivate)
)
'init-child-proc-result
)
(defun initializer-process-function (a0)
(format 0 "ipf: ~D~%" a0)
(let ((child-proc (get-process *nk-dead-pool* process 1024 #f)))
;; let's go
(activate child-proc *active-pool* "child-proc" *kernel-dram-stack*)
(format 0 "child-proc activated...~%")
(let ((result (run-function-in-process child-proc init-child-proc a0 2 3 4 5 6)))
(format 0 "child-proc reuslt: ~D~%" result)
(format #t "run-function-in-process result: ~A~%" result)
)
)
(format 0 "proc-deactivate ~D~%" a0)
(rlet ((pp :reg r13 :reset-here #t :type process))
;; (deactivate pp)
(format 0 " proc is: #x~X~%" pp)
)
(check-current-proc-catch-rbx)
(process-deactivate)
(format 0 "proc-deactivate end?~%")
)
(defun kernel-test-2 ()
(define initalizer-process (get-process *nk-dead-pool* process 1024 #f))
(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 #f))
(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
)
(format 0 "kt2 return~%")
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 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)
)
;; 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"
(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 #f)))
(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 #f)))
(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
)
(defun throw-backup-test ()
(rlet ((x :reg xmm10 :class fpr :type float))
(set! x 10.10)
(let ((proc (get-process *nk-dead-pool* process 1024 #f)))
(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)
)
)
)
test/goalc/test_goal_kernel3.cpp
+151
View File
@@ -0,0 +1,151 @@
#include <memory>
#include <thread>
#include "goalc/compiler/Compiler.h"
#include "gtest/gtest.h"
#include "test/goalc/framework/test_runner.h"
class Jak3KernelTest : public testing::Test {
public:
static void SetUpTestSuite() {
shared_compiler = std::make_unique<SharedCompiler>(GameVersion::Jak3);
printf("Building kernel...\n");
try {
// a macro in goal-lib.gc
shared_compiler->compiler.run_front_end_on_string("(build-kernel)");
} catch (std::exception& e) {
fprintf(stderr, "caught exception %s\n", e.what());
EXPECT_TRUE(false);
}
printf("Starting GOAL Kernel...\n");
shared_compiler->runtime_thread = std::thread(GoalTest::runtime_with_kernel_jak3);
shared_compiler->runner.c = &shared_compiler->compiler;
shared_compiler->compiler.run_test_from_string("(set! *use-old-listener-print* #t)");
}
static void TearDownTestSuite() {
// send message to shutdown
shared_compiler->compiler.shutdown_target();
// wait for shutdown.
shared_compiler->runtime_thread.join();
shared_compiler.reset();
}
void SetUp() {}
void TearDown() {}
struct SharedCompiler {
SharedCompiler(GameVersion v) : compiler(v) {}
std::thread runtime_thread;
Compiler compiler;
GoalTest::CompilerTestRunner runner;
};
static std::unique_ptr<SharedCompiler> shared_compiler;
};
std::unique_ptr<Jak3KernelTest::SharedCompiler> Jak3KernelTest::shared_compiler;
namespace {
std::string send_code_and_get_multiple_responses(const std::string& code,
int n_responses,
GoalTest::CompilerTestRunner* runner) {
auto& listener = runner->c->listener();
// record all print messages
listener.record_messages(ListenerMessageKind::MSG_PRINT);
// run the test.
runner->c->compile_and_send_from_string(code);
std::string result;
while (listener.get_received_message_count() < n_responses) {
std::this_thread::sleep_for(std::chrono::microseconds(1000));
}
auto messages = listener.stop_recording_messages();
for (auto& m : messages) {
result += m;
}
return result;
}
} // namespace
TEST_F(Jak3KernelTest, Basic) {
shared_compiler->runner.c->run_test_from_string(
"(ml \"test/goalc/source_templates/jak3/kernel-test.gc\")");
std::string result =
send_code_and_get_multiple_responses("(kernel-test)", 10, &shared_compiler->runner);
std::string expected =
"0\n"
"proc2: 0\n"
"TARGET FUNCTION 1 2 3\n"
"4 5 6\n"
"Stack Alignemnt 0/16\n"
"proc1: 0\n"
"proc2: 6\n"
"proc1: 1\n"
"proc2: 12\n"
"proc1: 2\n"
"proc2: 18\n"
"proc1: 3\n"
"proc2: 24\n"
"proc1: 4\n"
"proc2: 30\n"
"proc1: 5\n"
"DEACTIVATE PROC 1\n"
"proc2: 36\n"
"proc2: 42\n"
"proc2: 48\n"
"proc2: 54\n";
EXPECT_EQ(expected, result);
}
TEST_F(Jak3KernelTest, RunFunctionInProcess) {
shared_compiler->runner.c->run_test_from_string(
"(ml \"test/goalc/source_templates/jak3/kernel-test.gc\")");
std::string result =
send_code_and_get_multiple_responses("(kernel-test-2)", 1, &shared_compiler->runner);
std::string expected =
"0\n"
"Args: 1 2 3\n"
"4 5 6\n"
"Stack Alignemnt 0/16\n"
"run-function-in-process result: init-child-proc-result\n"
"Args: 0 2 3\n"
"4 5 6\n"
"Stack Alignemnt 0/16\n"
"run-function-in-process result: #f\n";
EXPECT_EQ(expected, result);
}
TEST_F(Jak3KernelTest, StateAndXmm) {
shared_compiler->runner.c->run_test_from_string(
"(ml \"test/goalc/source_templates/jak3/kernel-test.gc\")");
std::string result =
send_code_and_get_multiple_responses("(state-test)", 5, &shared_compiler->runner);
std::string expected =
"0\nenter wreck: 3 4 5 6\nwreck: 3 4 5 6\nenter check: 9 8 7 6\nrun xmm-check 12.3400 "
"45.6300 9 8 7 6\nwreck: 3 4 5 6\nrun xmm-check 12.3400 45.6300 9 8 7 6\nwreck: 3 4 5 6\nrun "
"xmm-check 12.3400 45.6300 9 8 7 6\nwreck: 3 4 5 6\nexit check\nenter die\ntime to "
"die!\nexit die\nexit wreck\nenter die\ntime to die!\nexit die\n";
EXPECT_EQ(expected, result);
}
TEST_F(Jak3KernelTest, ThrowXmm) {
shared_compiler->runner.c->run_test_from_string(
"(ml \"test/goalc/source_templates/jak3/kernel-test.gc\")");
std::string result =
send_code_and_get_multiple_responses("(throw-backup-test)", 1, &shared_compiler->runner);
std::string expected =
"value now is 10.1000\n"
"now its 10.1000\n"
"0\n";
EXPECT_EQ(expected, result);
}
test/offline/config/jak3/config.jsonc
+5
View File
@@ -13,6 +13,11 @@
"(method 9 inline-array-class-uint64)",
"breakpoint-range-set!",
"valid?",
// gkernel
"(method 10 process)",
"(method 14 dead-pool)",
// gstate
"enter-state", // stack pointer asm
// math
"logf",