mirror of
https://github.com/open-goal/jak-project
synced 2026-06-17 07:08:17 -04:00
Tyler Wilding
c162c66118
This PR does two main things: 1. Work through the main low-hanging fruit issues in the formatter keeping it from feeling mature and usable 2. Iterate and prove that point by formatting all of the Jak 1 code base. **This has removed around 100K lines in total.** - The decompiler will now format it's results for jak 1 to keep things from drifting back to where they were. This is controlled by a new config flag `format_code`. How am I confident this hasn't broken anything?: - I compiled the entire project and stored it's `out/jak1/obj` files separately - I then recompiled the project after formatting and wrote a script that md5's each file and compares it (`compare-compilation-outputs.py` - The results (eventually) were the same:  > This proves that the only difference before and after is non-critical whitespace for all code/macros that is actually in use. I'm still aware of improvements that could be made to the formatter, as well as general optimization of it's performance. But in general these are for rare or non-critical situations in my opinion and I'll work through them before doing Jak 2. The vast majority looks great and is working properly at this point. Those known issues are the following if you are curious: 
616 lines
33 KiB
Common Lisp
616 lines
33 KiB
Common Lisp
;;-*-Lisp-*-
|
|
(in-package goal)
|
|
(bundles "ENGINE.CGO" "GAME.CGO")
|
|
(require "engine/geometry/geometry-h.gc")
|
|
(require "engine/entity/res-h.gc")
|
|
(require "engine/gfx/texture/texture.gc")
|
|
|
|
#|
|
|
res is a generic storage system for not very large data, used mostly for the game entities.
|
|
These res files store collections of data, which can be as values (int8, int16, int32, int64, uint8, uint16, uint32, uint64, float, vector), or any structure (as references), which are tagged and identified with a res-tag.
|
|
The data is stored similar to an unboxed inline-array, the type of the data is stored in the res-tag.
|
|
|
|
A res-lump stores and is used to access all of the data for a single "resource", a collection of varying data.
|
|
This is similar to a C++ map or C# dictionary. The key is a res-tag and the value is the corresponding binary data.
|
|
|
|
A res-tag is a tag that contains information about a particular property of this resource, such as type, name, and amount of elements.
|
|
For example, information about an array of vectors that make up a path - for a moving platform - or an integer to store its entity ID.
|
|
|
|
Keyframes are used to specify when/where the data is relevant.
|
|
For example (this is made-up), say you have a camera spline, and you want the FOV to change at three specific points:
|
|
when it starts, somewhere in the middle, and at the end.
|
|
You would store an array of three FOV values. The key-frame field could then be used to say at which point in the spline
|
|
the FOV should be at that value. If the camera is somewhere between those points, the result could then be interpolated.
|
|
|
|
Properties are looked up from a res-lump using their name (a symbol).
|
|
You can look up the data of the property you want directly using the various get-property methods.
|
|
Curves can be quickly filled in using the get-curve-data! method.
|
|
|
|
|
|
This is updated from the entity system used in Crash 2, which had most of these features and worked very similarly!
|
|
|#
|
|
|
|
(defmacro res-ref? (tag)
|
|
"Checks resource tag, and returns #t if resource data is a reference type, #f if it is inlined."
|
|
`(zero? (-> ,tag inlined?)))
|
|
|
|
;; DECOMP BEGINS
|
|
|
|
(defmethod print ((this res-tag))
|
|
"print a res-tag."
|
|
(if (res-ref? this)
|
|
(format #t
|
|
"#<res-tag :name ~A :key-frame ~f :elt-type ~A :elt-count ~D>"
|
|
(-> this name)
|
|
(-> this key-frame)
|
|
(-> this elt-type)
|
|
(-> this elt-count))
|
|
(format #t
|
|
"#<res-tag (i) :name ~A :key-frame ~f :elt-type ~A :elt-count ~D>"
|
|
(-> this name)
|
|
(-> this key-frame)
|
|
(-> this elt-type)
|
|
(-> this elt-count)))
|
|
this)
|
|
|
|
(defmethod length ((this res-tag))
|
|
"get the length in bytes of this tag's resource."
|
|
(the int
|
|
(if (res-ref? this)
|
|
(* (-> this elt-count) 4) ;; elements are pointers/references to data.
|
|
(* (-> this elt-count) (-> this elt-type size)))))
|
|
|
|
(defmethod get-tag-index-data ((this res-lump) (n int))
|
|
"get the data address of the n'th tag."
|
|
(declare (inline))
|
|
(&+ (-> this data-base) (-> this tag n data-offset)))
|
|
|
|
(defmethod get-tag-data ((this res-lump) (tag res-tag))
|
|
"get the data address of the specified tag."
|
|
(declare (inline))
|
|
(&+ (-> this data-base) (-> tag data-offset)))
|
|
|
|
(defmethod new res-lump ((allocation symbol) (type-to-make type) (data-count int) (data-size int))
|
|
"Allocate a new res-lump."
|
|
(let ((this (object-new allocation
|
|
type-to-make
|
|
(the int (+ (-> type-to-make size) (* (1- data-count) (size-of res-tag)) data-size)))))
|
|
(set! (-> this allocated-length) data-count)
|
|
(set! (-> this data-size) data-size)
|
|
(set! (-> this length) 0)
|
|
(set! (-> this data-base) (&-> (-> this tag) data-count))
|
|
(set! (-> this data-top) (&-> (-> this tag) data-count))
|
|
this))
|
|
|
|
(defmethod length ((this res-lump))
|
|
"get the amount of resources in a res-lump."
|
|
(-> this length))
|
|
|
|
(defmethod asize-of ((this res-lump))
|
|
"get the allocated size of a res-lump."
|
|
(the int
|
|
(+ (-> this type psize) ;; psize is used here, but size is used in the allocation?
|
|
(* (-> this allocated-length) (size-of res-tag))
|
|
(-> this data-size))))
|
|
|
|
(defmethod inspect ((this res-lump))
|
|
(format #t "[~8x] ~A~%" this (-> this type))
|
|
(format #t "~Textra: ~A~%" (-> this extra))
|
|
(format #t "~Tallocated-length: ~D~%" (-> this allocated-length))
|
|
(format #t "~Tlength: ~D~%" (-> this length))
|
|
(format #t "~Tdata-base: #x~X~%" (-> this data-base))
|
|
(format #t "~Tdata-top: #x~X~%" (-> this data-top))
|
|
(format #t "~Tdata-size: #x~X~%" (-> this data-size))
|
|
(format #t "~Ttag[~D]: @ #x~X~%" (-> this allocated-length) (-> this tag))
|
|
(dotimes (i (-> this length))
|
|
(format #t "~T [~D] " i)
|
|
(print (-> (-> this tag) i))
|
|
(format #t " @ #x~X" (get-tag-index-data this i))
|
|
(cond
|
|
((res-ref? (-> this tag i)) (format #t " = ~A~%" (deref basic (get-tag-index-data this i))))
|
|
(else (format #t "~%"))))
|
|
this)
|
|
|
|
(defmethod lookup-tag-idx ((this res-lump) (name-sym symbol) (mode symbol) (time float))
|
|
"Look up the index of the tag containing with the given name and timestamp.
|
|
Correct lookups return a res-tag-pair, which contains one tag index in the lower 32 bits and one in the upper 32 bits.
|
|
Depending on the mode, they may be the same, or they may be two tags that you should interpolate
|
|
between, if the exact time was not found.
|
|
|
|
name-sym should be the name of the thing you want.
|
|
time is for the timestamp you want.
|
|
If mode = 'base, then both the indices are the same and the timestamp is ignored.
|
|
If mode = 'interp, then it tries to get closest below/closest above (or both the same, if exact match found)
|
|
If mode = 'exact, then it requires an exact timestamp match and both indices are the same.
|
|
If things go wrong, returns a negative number"
|
|
(local-vars (tag-idx int))
|
|
;; for some unknown reason, these names cannot be looked up with this method.
|
|
(when (or (= name-sym 'id)
|
|
(= name-sym 'aid)
|
|
(= name-sym 'trans)
|
|
(= name-sym 'rot)
|
|
(= name-sym 'nav-mesh)
|
|
(= name-sym 'process-type)
|
|
(= name-sym 'task))
|
|
(crash!))
|
|
;; check that we are valid.
|
|
(if (or (not this) (zero? this) (<= (-> this length) 0)) (return (the res-tag-pair -1)))
|
|
;; these are the outputs of the function.
|
|
(let ((hi-tag-idx-out -1)
|
|
(lo-tag-idx-out -1))
|
|
;; this value is the index of the most recently passed tag with an "invalid" timestamp
|
|
(let ((most-recent-invalid-time-idx -1)
|
|
;; read 8 chars of the name we want
|
|
(type-chars (-> (the-as (pointer uint64) (-> (symbol->string name-sym) data)) 0)))
|
|
;; now we will do a binary search. The names are stored in ascending order if you
|
|
;; treat the first 8 chars as an integer
|
|
;; min/max are inclusive.
|
|
(let ((max-search (+ (-> this length) -1))
|
|
(min-search 0))
|
|
;; inclusive, so >= is correct
|
|
(while (>= max-search min-search)
|
|
;; check in the middle of the range to bisect it.
|
|
(let* ((check-idx (+ min-search (/ (- max-search min-search) 2)))
|
|
;; subtract the two words. The sign of this tells us if we are too high or too low
|
|
(diff (- type-chars (-> (the-as (pointer uint64) (-> (symbol->string (-> (-> this tag) check-idx name)) data)) 0))))
|
|
(cond
|
|
((zero? diff)
|
|
;; perfect match! we are done, set the tag-idx and get out of here.
|
|
(set! tag-idx check-idx)
|
|
(goto cfg-32))
|
|
(else
|
|
;; didn't match. pick the appropriate half of the remaining tags
|
|
(if (< (the-as int diff) 0) (set! max-search (+ check-idx -1)) (set! min-search (+ check-idx 1))))))))
|
|
;; got to the end of the loop without finding the answer. Set a negative tag
|
|
(set! tag-idx -1)
|
|
(label cfg-32)
|
|
(if (< tag-idx 0) (return (the res-tag-pair tag-idx)))
|
|
;; if there are multiple tags with the same name and different timesteps, we can't be sure which we ended on.
|
|
;; this loop brings us to the first tag with the correct name.
|
|
(while (and (> tag-idx 0)
|
|
(= type-chars (-> (the-as (pointer uint64) (-> (symbol->string (-> (-> this tag) (+ tag-idx -1) name)) data)) 0)))
|
|
(+! tag-idx -1))
|
|
;; in 'base mode, we just want the earliest tag with the right name.
|
|
;; tags are in increasing timestamps, so we found it!
|
|
(if (= mode 'base)
|
|
(begin
|
|
;; both lo and hi are the same
|
|
(set! lo-tag-idx-out tag-idx)
|
|
(set! hi-tag-idx-out tag-idx)
|
|
(goto cfg-73)))
|
|
;; next we will iterate through tags with the right name and find the one(s) with the right timestamp
|
|
;; interp-tag-idx is the index of tag-ptr always
|
|
;; (the fact that they keep a pointer to a tag and not actually load the tag makes it seem like
|
|
;; they ran into some 128-bit integer issues here...)
|
|
(let ((interp-tag-idx tag-idx)
|
|
(tag-ptr (&-> (-> this tag) tag-idx)))
|
|
;; loop, until we reach another name or the end of the table
|
|
(while (not (or (>= interp-tag-idx (-> this length))
|
|
;; < is correct here because we are incrementing and names get larger
|
|
(< type-chars (-> (the-as (pointer uint64) (-> (symbol->string (-> tag-ptr 0 name)) data)) 0))))
|
|
(cond
|
|
;; The checks above only made sure that the first 8 chars were correct.
|
|
;; This skips items with matching first 8 chars, but differences after that.
|
|
((!= name-sym (-> tag-ptr 0 name)))
|
|
;; check for exact match
|
|
((= (-> tag-ptr 0 key-frame) time)
|
|
;; in all cases, just return the exact match.
|
|
(begin
|
|
(set! lo-tag-idx-out interp-tag-idx)
|
|
(set! hi-tag-idx-out interp-tag-idx)
|
|
(goto cfg-73)))
|
|
;; check for being not far enough
|
|
((and (>= time (-> tag-ptr 0 key-frame)) (!= mode 'exact))
|
|
;; in all cases, except for exact, we'll want to remember this.
|
|
;; just in case there are no more tags
|
|
(set! lo-tag-idx-out interp-tag-idx)
|
|
(set! hi-tag-idx-out interp-tag-idx)
|
|
;; also remember if we hit an invalid one
|
|
(if (= (-> tag-ptr 0 key-frame) -1000000000.0) (set! most-recent-invalid-time-idx interp-tag-idx)))
|
|
;; check for being too far (passed the time)
|
|
((< time (-> tag-ptr 0 key-frame))
|
|
(begin
|
|
;; if we're interpolation mode and valid, set the high one.
|
|
;; not sure what the invalid time thing is about.
|
|
(if (and (!= lo-tag-idx-out most-recent-invalid-time-idx) (= mode 'interp)) (set! hi-tag-idx-out interp-tag-idx))
|
|
(goto cfg-73))))
|
|
;; advance to next tag
|
|
(+! interp-tag-idx 1)
|
|
(set! tag-ptr (&-> tag-ptr 1)))))
|
|
(label cfg-73)
|
|
;; end: return the tags.
|
|
(the-as res-tag-pair (logior (logand #xffffffff (the-as uint lo-tag-idx-out)) (the-as uint (shl hi-tag-idx-out 32))))))
|
|
|
|
(defmacro make-res-int-data (interp elt-count buf src-lo src-hi ty)
|
|
`(let ((fixed-pt (the int (* 4096.0 ,interp))))
|
|
(dotimes (i ,elt-count)
|
|
(set! (deref ,ty ,buf 0) (ash (+ (* (deref ,ty ,src-lo i) (- 4096 fixed-pt)) (* (deref ,ty ,src-hi i) fixed-pt)) -12)))
|
|
buf))
|
|
|
|
(defmethod make-property-data ((this res-lump) (time float) (tag-pair res-tag-pair) (buf pointer))
|
|
"Returns (a pointer to) the value data of a property with the tag-pair.
|
|
If tag-pair does not represent an exact point in the timeline, then the data is interpolated based on time
|
|
with the result written into buf. buf must have enough space to copy all of the data.
|
|
Otherwise, simply returns an address to the resource binary."
|
|
(let* ((tag-lo (-> this tag (-> tag-pair lo)))
|
|
(tag-hi (-> this tag (-> tag-pair hi)))
|
|
(elt-count (-> tag-lo elt-count)))
|
|
(cond
|
|
((res-ref? tag-lo) (get-tag-data this tag-lo))
|
|
((or (not buf)
|
|
(= (-> tag-pair lo) (-> tag-pair hi))
|
|
(!= elt-count (-> tag-hi elt-count))
|
|
(!= (-> tag-lo elt-type) (-> tag-hi elt-type)))
|
|
(get-tag-data this tag-lo))
|
|
(else
|
|
(let ((interp (/ (- time (-> tag-lo key-frame)) (- (-> tag-hi key-frame) (-> tag-lo key-frame)))) ;; DBZ
|
|
(src-lo (get-tag-data this tag-lo))
|
|
(src-hi (get-tag-data this tag-hi)))
|
|
(case (-> tag-lo elt-type symbol)
|
|
(('float)
|
|
(dotimes (i elt-count)
|
|
(set! (deref float buf 0) (+ (* (deref float src-lo i) (- 1.0 interp)) (* (deref float src-hi i) interp))))
|
|
buf)
|
|
(('integer 'sinteger 'uinteger 'int64 'uint64) (make-res-int-data interp elt-count buf src-lo src-hi uint64))
|
|
(('int8) (make-res-int-data interp elt-count buf src-lo src-hi int8))
|
|
(('uint8) (make-res-int-data interp elt-count buf src-lo src-hi uint8))
|
|
(('int16) (make-res-int-data interp elt-count buf src-lo src-hi int16))
|
|
(('uint16) (make-res-int-data interp elt-count buf src-lo src-hi uint16))
|
|
(('int32) (make-res-int-data interp elt-count buf src-lo src-hi int32))
|
|
(('uint32) (make-res-int-data interp elt-count buf src-lo src-hi uint32))
|
|
(('vector)
|
|
(rlet ((vf1 :class vf)
|
|
(vf2 :class vf)
|
|
(vf3 :class vf)
|
|
(vf4 :class vf))
|
|
(.mov vf3 interp)
|
|
(.mov vf4 (- 1.0 interp))
|
|
(dotimes (i elt-count)
|
|
(.lvf vf1 (&deref int128 src-lo i))
|
|
(.lvf vf2 (&deref int128 src-hi i))
|
|
(.mul.x.vf vf1 vf1 vf4)
|
|
(.mul.x.vf vf2 vf2 vf3)
|
|
(.add.vf vf1 vf1 vf2)
|
|
(.svf (&deref int128 buf i) vf1)))
|
|
buf)
|
|
(else (get-tag-data this tag-lo))))))))
|
|
|
|
(defmethod get-property-data ((this res-lump) (name symbol) (mode symbol) (time float) (default pointer) (tag-addr (pointer res-tag)) (buf-addr pointer))
|
|
"Returns an address to a given property's data at a specific time stamp, or default on error.
|
|
name is the name of the property you want, mode is its lookup mode ('interp 'base 'exact), time is the timestamp.
|
|
default is the default result returned in the case of an error.
|
|
tag-addr is an address to a res-tag. The current base tag is written to this. Ignored if tag-addr is #f
|
|
buf-addr is an address to the data buffer used to write interpolated data to. It must have enough space! Only necessary for 'interp mode."
|
|
(let ((tag-pair (lookup-tag-idx this name mode time)))
|
|
(cond
|
|
((< (the-as int tag-pair) 0) (empty))
|
|
(else
|
|
(set! default (make-property-data this time tag-pair buf-addr))
|
|
(if tag-addr (set! (-> tag-addr) (-> this tag (-> tag-pair lo)))))))
|
|
default)
|
|
|
|
(defmethod get-property-struct ((this res-lump) (name symbol) (mode symbol) (time float) (default structure) (tag-addr (pointer res-tag)) (buf-addr pointer))
|
|
"Returns a given struct property's value at a specific time stamp, or default on error.
|
|
name is the name of the property you want, mode is its lookup mode ('interp 'base 'exact), time is the timestamp.
|
|
default is the default result returned in the case of an error.
|
|
tag-addr is an address to a res-tag. The current base tag is written to this. Ignored if tag-addr is #f
|
|
buf-addr is an address to the data buffer used to write interpolated data to. It must have enough space! Only necessary for 'interp mode."
|
|
(let ((tag-pair (lookup-tag-idx this name mode time)))
|
|
(cond
|
|
((< (the-as int tag-pair) 0) (empty))
|
|
(else
|
|
(set! default (the-as structure (make-property-data this time tag-pair buf-addr)))
|
|
(let ((tag (-> this tag (-> tag-pair lo))))
|
|
(if tag-addr (set! (-> tag-addr 0) tag))
|
|
(if (res-ref? tag) (set! default (deref structure default)) (empty))))))
|
|
default)
|
|
|
|
(defmethod get-property-value ((this res-lump) (name symbol) (mode symbol) (time float) (default uint128) (tag-addr (pointer res-tag)) (buf-addr pointer))
|
|
"Returns a given value property's value at a specific time stamp, or default on error.
|
|
name is the name of the property you want, mode is its lookup mode ('interp 'base 'exact), time is the timestamp.
|
|
default is the default result returned in the case of an error.
|
|
tag-addr is an address to a res-tag. The current base tag is written to this. Ignored if tag-addr is #f
|
|
buf-addr is an address to the data buffer used to write interpolated data to. It must have enough space! Only necessary for 'interp mode."
|
|
(let ((tag-pair (lookup-tag-idx this name mode time)))
|
|
(cond
|
|
((< (the-as int tag-pair) 0))
|
|
(else
|
|
(let* ((tag (-> this tag (-> tag-pair lo)))
|
|
(tag-type (-> tag elt-type))
|
|
(data (make-property-data this time tag-pair buf-addr)))
|
|
(if tag-addr (set! (-> tag-addr 0) tag))
|
|
(cond
|
|
((type-type? tag-type uinteger)
|
|
(case (-> tag elt-type size)
|
|
((1) (set! default (the-as uint128 (deref uint8 data))))
|
|
((2) (set! default (the-as uint128 (deref uint16 data))))
|
|
((4) (set! default (the-as uint128 (deref uint32 data))))
|
|
((16) (set! default (the-as uint128 (deref uint128 data))))
|
|
(else (set! default (the-as uint128 (deref uint64 data))))))
|
|
((type-type? tag-type integer)
|
|
(case (-> tag elt-type size)
|
|
((1) (set! default (the-as uint128 (deref int8 data))))
|
|
((2) (set! default (the-as uint128 (deref int16 data))))
|
|
((4) (set! default (the-as uint128 (deref int32 data))))
|
|
((16) (set! default (the-as uint128 (deref uint128 data))))
|
|
(else (set! default (the-as uint128 (deref uint64 data))))))
|
|
((type-type? tag-type float) (set! default (the-as uint128 (deref float data))))
|
|
(else))))))
|
|
default)
|
|
|
|
(defmethod get-property-value-float ((this res-lump) (name symbol) (mode symbol) (time float) (default float) (tag-addr (pointer res-tag)) (buf-addr pointer))
|
|
"same as get-property-value but float type is checked first?"
|
|
(let ((tag-pair (lookup-tag-idx this name mode time)))
|
|
(cond
|
|
((< (the-as int tag-pair) 0) (empty))
|
|
(else
|
|
(let* ((tag (-> this tag (-> tag-pair lo)))
|
|
(tag-type (-> tag elt-type))
|
|
(data (make-property-data this time tag-pair buf-addr)))
|
|
(if tag-addr (set! (-> tag-addr 0) tag))
|
|
(cond
|
|
((type-type? tag-type float) (set! default (deref float data)))
|
|
((type-type? tag-type uinteger)
|
|
(case (-> tag elt-type size)
|
|
((1) (set! default (the float (deref uint8 data))))
|
|
((2) (set! default (the float (deref uint16 data))))
|
|
((4) (set! default (the float (deref uint32 data))))
|
|
((16) (set! default (the float (deref uint128 data))))
|
|
(else (set! default (the float (deref uint64 data))))))
|
|
((type-type? tag-type integer)
|
|
(case (-> tag elt-type size)
|
|
((1) (set! default (the float (deref int8 data))))
|
|
((2) (set! default (the float (deref int16 data))))
|
|
((4) (set! default (the float (deref int32 data))))
|
|
((16) (set! default (the float (deref uint128 data))))
|
|
(else (set! default (the float (deref uint64 data))))))
|
|
(else (empty)))))))
|
|
default)
|
|
|
|
(defmethod sort! ((this res-lump))
|
|
"Sort all tags based on name, then key-frame."
|
|
(let ((tags-sorted -1))
|
|
(while (nonzero? tags-sorted)
|
|
(set! tags-sorted 0)
|
|
(let ((i 0)
|
|
(tag-stop (+ (-> this length) -2)))
|
|
(while (>= tag-stop i)
|
|
(let* ((tag1 (-> this tag i))
|
|
(tag2 (-> this tag (1+ i)))
|
|
(tag-name1 (deref uint64 (-> (symbol->string (-> tag1 name)) data)))
|
|
(tag-name2 (deref uint64 (-> (symbol->string (-> tag2 name)) data))))
|
|
(when (or (< tag-name2 tag-name1) (and (= tag-name1 tag-name2) (< (-> tag2 key-frame) (-> tag1 key-frame))))
|
|
(1+! tags-sorted)
|
|
(set! (-> this tag i) tag2)
|
|
(set! (-> this tag (1+ i)) tag1)))
|
|
(1+! i)))))
|
|
this)
|
|
|
|
(defmethod allocate-data-memory-for-tag! ((this res-lump) (arg0 res-tag))
|
|
"Find space for the data described by arg0 in `this`.
|
|
Returns a tag with data-offset set correctly for this res-lump.
|
|
If the lump already contains memory for the given tag, and it is big enough,
|
|
it will be reused. Alignment will be at least 8 bytes.
|
|
If the input tag has elt-count = 0, it will return a tag for elt-count = 1."
|
|
(local-vars (resource-mem pointer))
|
|
;; first, look up the tag to see if it already exists in this res-lump
|
|
(let ((tag-pair (lookup-tag-idx this (-> arg0 name) 'exact (-> arg0 key-frame))))
|
|
(let ((existing-tag (-> this tag (-> tag-pair lo))))
|
|
;; If our existing tag is valid, but our key-frame is NaN, then we forget about it.
|
|
(if (and (>= (the-as int tag-pair) 0)
|
|
(!= (-> arg0 key-frame) (-> arg0 key-frame)) ;; check for NaN
|
|
)
|
|
(set! tag-pair (new 'static 'res-tag-pair :lo #xffffffff :hi #xffffffff)))
|
|
;; modify the input to have at least one element
|
|
(if (zero? (-> arg0 elt-count)) (set! (-> arg0 elt-count) 1))
|
|
;; next, we try to find some memory
|
|
(let ((data-size (length arg0))) ;; size in bytes to store the data.
|
|
(cond
|
|
((and (>= (the-as int tag-pair) 0) (>= (the-as uint (length existing-tag)) (the-as uint data-size)))
|
|
;; we have enough memory in the existing tag.
|
|
;; so we can just reuse it.
|
|
(set! resource-mem (&+ (-> this data-base) (-> existing-tag data-offset)))
|
|
;; but we want at least 8 byte alignment. If this fails, allocate with 16-byte alignment from the top.
|
|
(when (nonzero? (logand (the-as int resource-mem) 7))
|
|
(set! resource-mem (logand -16 (&+ (-> this data-top) 15)))
|
|
(set! (-> this data-top) (&+ resource-mem data-size))))
|
|
(else
|
|
;; the existing tag wasn't there, or it wasn't big enough.
|
|
;; just allocate new memory.
|
|
(set! resource-mem (logand -16 (&+ (-> this data-top) 15)))
|
|
(set! (-> this data-top) (&+ resource-mem data-size))))
|
|
;; set our data offset.
|
|
(set! (-> arg0 data-offset) (&- resource-mem (the-as uint (-> this data-base))))
|
|
;; check for overflow of the data memory
|
|
;; this will leave things in a bad state.
|
|
(when (>= (the-as int (&+ resource-mem data-size)) (the-as int (&+ (-> this data-base) (-> this data-size))))
|
|
(format 0
|
|
"ERROR: attempting to a new tag ~`res-tag`P data of #x~X bytes to ~A, but data memory is full.~%"
|
|
arg0
|
|
data-size
|
|
this)
|
|
(return (the-as res-tag #f)))))
|
|
;; next step is to add us to the list of tags.
|
|
(cond
|
|
((< (the-as int tag-pair) 0)
|
|
;; we couldn't reuse an existing tag. Need to allocate another
|
|
(cond
|
|
((>= (-> this length) (-> this allocated-length))
|
|
;; but there isn't room for another tag.
|
|
(format 0 "ERROR: attempting to a new tag ~`res-tag`P to ~A, but tag memory is full.~%" arg0 this)
|
|
(return (the-as res-tag #f)))
|
|
(else
|
|
;; allocate a new tag and sort, so the binary search works properly.
|
|
(set! (-> this tag (-> this length)) arg0)
|
|
(set! (-> this length) (+ (-> this length) 1))
|
|
(sort! this))))
|
|
(else
|
|
;; reuse the existing tag.
|
|
(set! (-> this tag (-> tag-pair lo)) arg0))))
|
|
arg0)
|
|
|
|
(defmethod add-data! ((this res-lump) (arg0 res-tag) (arg1 pointer))
|
|
"Given a tag and a pointer to its data, copy it to this res-lump.
|
|
This doesn't seem to do the right thing if the given tag is a non-inline tag
|
|
with > 1 element."
|
|
;; get a tag for this lump with memory for the given tag.
|
|
(let ((new-tag (allocate-data-memory-for-tag! this arg0)))
|
|
(when new-tag
|
|
;; get pointer to new tag's memory
|
|
(let* ((v1-2 this)
|
|
(a1-1 new-tag)
|
|
(tag-mem (&+ (-> v1-2 data-base) (-> a1-1 data-offset))))
|
|
(cond
|
|
((zero? (-> new-tag inlined?))
|
|
;; this seems wrong, it should loop over the length maybe?
|
|
(length new-tag) ;; unused?
|
|
(set! (-> (the-as (pointer pointer) tag-mem)) arg1))
|
|
(else
|
|
;; otherwise, copy the memory.
|
|
(let ((a2-1 (length new-tag))) (mem-copy! tag-mem arg1 a2-1)))))))
|
|
this)
|
|
|
|
(defmethod add-32bit-data! ((this res-lump) (arg0 res-tag) (arg1 object))
|
|
"Add a single 32-bit value using add-data."
|
|
(set! (-> arg0 inlined?) 1)
|
|
(add-data! this arg0 (& arg1)) ;; note, only 32-bits are spilled to the stack here.
|
|
#|
|
|
(local-vars (sv-16 object))
|
|
(set! sv-16 arg1)
|
|
(let* ((v1-0 arg0)
|
|
(a1-4 (copy-and-set-bf v1-0 :inlined? 1))
|
|
)
|
|
(add-data! this a1-4 (& sv-16))
|
|
)
|
|
|#
|
|
)
|
|
|
|
(defmethod get-curve-data! ((this res-lump) (curve-target curve) (points-name symbol) (knots-name symbol) (time float))
|
|
"Read curve data and write it to curve-target. Return #t if both control points and knots data was succesfully read, #f otherwise."
|
|
(let ((result #f))
|
|
;; there's some macro here
|
|
(let* ((points-tag (new 'static 'res-tag))
|
|
(curve-data (get-property-data this points-name 'exact time (the pointer #f) (& points-tag) *res-static-buf*)))
|
|
(when curve-data
|
|
(set! (-> curve-target cverts) (the-as (inline-array vector) curve-data))
|
|
(set! (-> curve-target num-cverts) (the int (-> points-tag elt-count)))
|
|
(when (< MAX_CURVE_CONTROL_POINTS (-> curve-target num-cverts))
|
|
(format 0
|
|
"ERROR<GMJ>: curve has ~D control points--only ~D are allowed. Increase MAX-CURVE-CONTROL-POINTS or shorten the curve.~%"
|
|
(-> curve-target num-cverts)
|
|
MAX_CURVE_CONTROL_POINTS)
|
|
(set! (-> curve-target num-cverts) MAX_CURVE_CONTROL_POINTS))
|
|
(let ((knots-tag (new 'static 'res-tag)))
|
|
(set! curve-data (get-property-data this knots-name 'exact time (the pointer #f) (& knots-tag) *res-static-buf*))
|
|
(when curve-data
|
|
(set! (-> curve-target knots) (the (pointer float) curve-data))
|
|
(set! (-> curve-target num-knots) (the int (-> knots-tag elt-count)))
|
|
(set! result #t)))))
|
|
result))
|
|
|
|
(define-extern part-group-pointer? (function pointer symbol))
|
|
|
|
(declare-type nav-mesh basic)
|
|
|
|
(declare-type collide-mesh basic)
|
|
|
|
(defmethod mem-usage ((this res-lump) (block memory-usage-block) (flags int))
|
|
"Get the memory usage of this lump and its data"
|
|
(local-vars (sv-16 int))
|
|
;; get the name and ID
|
|
(let ((mem-use-id (mem-usage-id res))
|
|
(mem-use-name "res"))
|
|
(cond
|
|
((nonzero? (logand flags 256)) (set! mem-use-id (mem-usage-id camera)) (set! mem-use-name "camera"))
|
|
((nonzero? (logand flags 64)) (set! mem-use-id (mem-usage-id entity)) (set! mem-use-name "entity"))
|
|
((nonzero? (logand flags 128)) (set! mem-use-id (mem-usage-id ambient)) (set! mem-use-name "ambient"))
|
|
((nonzero? (logand flags 512)) (set! mem-use-id (mem-usage-id art-joint-geo)) (set! mem-use-name "art-joint-geo")))
|
|
;; set up the block
|
|
(set! (-> block length) (max (-> block length) (+ mem-use-id 1)))
|
|
(set! (-> block data mem-use-id name) mem-use-name)
|
|
;; the lump counts as 1 in the count field
|
|
(set! (-> block data mem-use-id count) (+ (-> block data mem-use-id count) 1))
|
|
;; add the size of the lump itself.
|
|
(let ((obj-size (asize-of this)))
|
|
(set! (-> block data mem-use-id used) (+ (-> block data mem-use-id used) obj-size))
|
|
(set! (-> block data mem-use-id total) (+ (-> block data mem-use-id total) (logand -16 (+ obj-size 15)))))
|
|
;; add the tags
|
|
(dotimes (tag-idx (-> this length))
|
|
(when (zero? (-> this tag tag-idx inlined?))
|
|
(let* ((a1-4 this)
|
|
(a0-15 tag-idx)
|
|
(tag-data (the-as basic (-> (the-as (pointer uint32) (&+ (-> a1-4 data-base) (-> a1-4 tag a0-15 data-offset)))))))
|
|
;; ref to non-inline data. Inline data would have been counted above.
|
|
(when (not (part-group-pointer? (the-as pointer tag-data)))
|
|
(case (-> (the-as basic tag-data) type)
|
|
((symbol type))
|
|
((string)
|
|
;; strings add like a normal object.
|
|
;; this seems identical to the else case.
|
|
(set! (-> block length) (max (-> block length) (+ mem-use-id 1)))
|
|
(set! (-> block data mem-use-id name) mem-use-name)
|
|
(set! (-> block data mem-use-id count) (+ (-> block data mem-use-id count) 1))
|
|
(let ((v1-47 (asize-of tag-data)))
|
|
(set! (-> block data mem-use-id used) (+ (-> block data mem-use-id used) v1-47))
|
|
(set! (-> block data mem-use-id total) (+ (-> block data mem-use-id total) (logand -16 (+ v1-47 15))))))
|
|
((nav-mesh collide-mesh)
|
|
;; these have their own implementation.
|
|
(mem-usage tag-data block flags))
|
|
((array)
|
|
(set! (-> block length) (max (-> block length) (+ mem-use-id 1)))
|
|
(set! (-> block data mem-use-id name) mem-use-name)
|
|
(set! (-> block data mem-use-id count) (+ (-> block data mem-use-id count) 1))
|
|
(let ((v1-63 (asize-of (the-as (array object) tag-data))))
|
|
(set! (-> block data mem-use-id used) (+ (-> block data mem-use-id used) v1-63))
|
|
(set! (-> block data mem-use-id total) (+ (-> block data mem-use-id total) (logand -16 (+ v1-63 15)))))
|
|
;; call mem usage on all of our children.
|
|
(set! sv-16 0)
|
|
(while (< sv-16 (-> (the-as array tag-data) length))
|
|
(let ((a0-58 (-> (the-as (array object) tag-data) sv-16)))
|
|
((method-of-type (rtype-of a0-58) mem-usage) a0-58 block flags))
|
|
(set! sv-16 (+ sv-16 1))))
|
|
(else
|
|
;; unknown type.
|
|
;; we assume its nothing fancy and use the asize of.
|
|
(set! (-> block length) (max (-> block length) (+ mem-use-id 1)))
|
|
(set! (-> block data mem-use-id name) mem-use-name)
|
|
(set! (-> block data mem-use-id count) (+ (-> block data mem-use-id count) 1))
|
|
(let ((v1-88 (asize-of tag-data)))
|
|
(set! (-> block data mem-use-id used) (+ (-> block data mem-use-id used) v1-88))
|
|
(set! (-> block data mem-use-id total) (+ (-> block data mem-use-id total) (logand -16 (+ v1-88 15))))))))))))
|
|
(the-as res-lump 0))
|
|
|
|
(define *res-static-buf* (malloc 'global 128))
|
|
|
|
;; There are four common types of lookup:
|
|
;; data. This is something like (pointer int32) or (inline-array vector), it should have a size.
|
|
;; struct. This will get a GOAL struct or basic. Like a string.
|
|
;; value. This will get a value. Possibly even a 128-bit value, though this does not appear to work properly.
|
|
;; float. This will get a float. If the value stored is an int, it will be converted to a float.
|
|
|
|
(defmacro res-lump-data (lump name type &key (tag-ptr (the-as (pointer res-tag) #f)) &key (time -1000000000.0))
|
|
"Helper macro to get data from a res-lump without interpolation."
|
|
`(the-as ,type
|
|
((method-of-type res-lump get-property-data) ,lump ,name 'interp ,time (the-as pointer #f) ,tag-ptr *res-static-buf*)))
|
|
|
|
(defmacro res-lump-data-exact (lump name type &key (tag-ptr (the-as (pointer res-tag) #f)) &key (time 0.0))
|
|
"Helper macro to get start of data from a res-lump."
|
|
`(the-as ,type
|
|
((method-of-type res-lump get-property-data) ,lump ,name 'exact ,time (the-as pointer #f) ,tag-ptr *res-static-buf*)))
|
|
|
|
(defmacro res-lump-struct (lump name type &key (tag-ptr (the-as (pointer res-tag) #f)) &key (time -1000000000.0))
|
|
`(the-as ,type
|
|
((method-of-type res-lump get-property-struct) ,lump ,name 'interp ,time (the-as structure #f) ,tag-ptr *res-static-buf*)))
|
|
|
|
(defmacro res-lump-struct-exact (lump name type &key (tag-ptr (the-as (pointer res-tag) #f)) &key (time 0.0))
|
|
`(the-as ,type
|
|
((method-of-type res-lump get-property-struct) ,lump ,name 'exact ,time (the-as structure #f) ,tag-ptr *res-static-buf*)))
|
|
|
|
(defmacro res-lump-value (lump name type &key (tag-ptr (the-as (pointer res-tag) #f)) &key (default (the-as uint128 0)) &key (time -1000000000.0))
|
|
"Helper macro to get a value from a res-lump with no interpolation."
|
|
`(the-as ,type ((method-of-type res-lump get-property-value) ,lump ,name 'interp ,time ,default ,tag-ptr *res-static-buf*)))
|
|
|
|
(defmacro res-lump-float (lump name &key (tag-ptr (the-as (pointer res-tag) #f)) &key (default 0.0) &key (time -1000000000.0))
|
|
"Helper macro to get a float from a res-lump with no interpolation."
|
|
`((method-of-type res-lump get-property-value-float) ,lump ,name 'interp ,time ,default ,tag-ptr *res-static-buf*))
|