mirror of
https://github.com/open-goal/jak-project.git
synced 2024-10-20 21:27:52 -04:00
506b5d8ceb
* decomp: `prototype` done * tests/ref: Update all reference tests * decomp: `video` done * decomp: Add `video` to src * decomp: `vol-h` done * tests/ref: Update reference tests again * decomp: Add `vol-h` to ref tests, leave `entity` in process as a `basic` for now! * decomp: `air-h` done, compiler issue though * decomp: `nav-enemy-h` done, compiler issue though * decomp: `rigid-body-h` done, compiler issue though * Address feedback and fix the failing to compile files * linting * finish `video` off
1661 lines
61 KiB
Common Lisp
1661 lines
61 KiB
Common Lisp
;;-*-Lisp-*-
|
|
(in-package goal)
|
|
|
|
;; name: texture.gc
|
|
;; name in dgo: texture
|
|
;; dgos: GAME, ENGINE
|
|
|
|
;; VRAM can belong to the following categories:
|
|
;; - frame/depth buffer (not handled through this system at all)
|
|
;; - special "global" VRAM that doesn't use texture, but is allocated through the texture-pool
|
|
;; (used for effects)
|
|
;; - "fixed textures" that live in VRAM always and aren't kept in RAM.
|
|
;; (common textures for Jak, crates, etc)
|
|
;; - "global common" textures that are uploaded as needed, but aren't level specific
|
|
;; (the start menu hud)
|
|
;; - "level common" textures that are uploaded as needed
|
|
;; - "level near" textures. Part of these textures remain in VRAM always (don't live in RAM) and
|
|
;; part is reuploaded as needed. This is for TFRAG stuff near the camera
|
|
|
|
;; common/near textures use a lazy loading scheme to avoid loading texture data that happens to already
|
|
;; be in the right spot.
|
|
|
|
;; During a level load, the first texture-page loaded is TFRAG, which contains both "near" and "common" data.
|
|
;; TFRAG is the only known thing to use "near"
|
|
|
|
;; Note: there is something weird going on with the zoomer hud texture.
|
|
|
|
;; On the DVD, textures are stored in "tpage files". Each file contains:
|
|
;; - a texture-page object, describing the file
|
|
;; - a texture object per texture, describing each texture (possibly multiple textures, mipmapped textures are considered 1 "texture")
|
|
;; the texture system will update these texture records to point the correct location in VRAM.
|
|
;; - the "block-data" - the actual texture data.
|
|
|
|
;; To make texture uploads as fast as possible, all data is designed to be uploaded as ct32, width 128.
|
|
;; The GS will end up scrambling up the data during the upload, but the tpage files are pre-scrambled in
|
|
;; the correct way to make everything work out.
|
|
;; This avoids having to load in other formats, which are slower.
|
|
|
|
;; Additionally, each texture-page is divided into three segments.
|
|
;; For TFRAG textures, segment 2 is "near" and segment 1 and 0 is "common"
|
|
|
|
;; To manage VRAM, there is a single texture-pool. It also has segments.
|
|
;; - near segment (level near textures)
|
|
;; - common segment (level and global common textures)
|
|
|
|
;; textures that are _always_ in VRAM (starting at boot) do not go in either of these segments
|
|
|
|
;; the common segment is shared between texture pages. There is lazy loading for this.
|
|
|
|
;; the near segment is shared between 2 texture pages - one per each level.
|
|
;; the first 0x24000 words are for level 0, and the last 0x24000 words are for level 1.
|
|
;; the stuff in the middle is shared and lazily loaded as needed.
|
|
|
|
;; there are 5 texture uploads per frame:
|
|
;; - TFRAG
|
|
;; - PRIS
|
|
;; - SHRUB
|
|
;; - ALPHA
|
|
;; - WATER
|
|
;; it is unknown how this works when drawing two levels.
|
|
|
|
;; Generally, "dest" refers to a location in vram, specified in 32-bit words.
|
|
;; block-data is a pointer to EE memory containing texture data.
|
|
|
|
;; There is a single "texture-pool" which is responsible for managing the vram.
|
|
;; it does not consider the frame/depth buffer.
|
|
|
|
;; There are three main units to describe VRAM:
|
|
;; words: 32-bit words, interally this is how the GS addresses things. "dest"/"size" is in words usually
|
|
;; blocks: 256 bytes, or 64 words. Some things in the GS must be block aligned, like transfers of textures.
|
|
;; KB: kilobytes, used only for diagnostic printing. 2^10 bytes (1024)
|
|
;; "ND page". Twice the size of a GS page.
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; texture-page type
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; texture-page = file on DVD containing a bunch of textures.
|
|
;; they are designed so that you load the TFRAG page, do TFRAG rendering,
|
|
;; load the PRIS page, do PRIS rendering, etc.
|
|
|
|
;; they also contain records of textures. The texture system will update these records
|
|
;; to reflect where the textures are actually placed in VRAM.
|
|
;; However, it is possible that multiple texture are assigned to the same destination.
|
|
;; You can check for this by looking at the texture-pool ids.
|
|
;; Or, use the upload-vram-pages function which will add uploads to a DMA chain only if needed.
|
|
|
|
(defmethod print texture-page ((obj texture-page))
|
|
"Print a short description of a texture page."
|
|
(format #t "#<texture-page ~S :length ~D :dest #x~X :size ~DK @ #x~X>"
|
|
(-> obj name)
|
|
(-> obj length) ;; number of textures.
|
|
(shr (-> obj segment 0 dest) 6) ;; destination (vram words (4 byte) -> blocks (256 byte))
|
|
(shr (-> obj size) 8) ;; size (vram words -> kilobytes)
|
|
obj
|
|
)
|
|
obj
|
|
)
|
|
|
|
(defmethod length texture-page ((obj texture-page))
|
|
"Get the number of textures in a texture page"
|
|
(-> obj length)
|
|
)
|
|
|
|
(defmethod asize-of texture-page ((obj texture-page))
|
|
"Get the size in memory of a texture page object, not including the actual texture objects or texture data"
|
|
(the-as int (+ (-> obj type size) (the-as uint (shl (-> obj length) 2))))
|
|
)
|
|
|
|
(defmethod mem-usage texture-page ((obj texture-page) (arg0 memory-usage-block) (arg1 int))
|
|
"Update the mem-usage for a texture."
|
|
|
|
;; some setup for texture memory usage.
|
|
(set! (-> arg0 length) (max (+ 1 (mem-usage-id-int texture)) (-> arg0 length)))
|
|
(set! (-> arg0 data (mem-usage-id texture) name) "texture")
|
|
|
|
;; count will hold the number of textures.
|
|
(set! (-> arg0 data (mem-usage-id texture) count)
|
|
(+ (-> arg0 data (mem-usage-id texture) count) (-> obj length)))
|
|
|
|
;; We subtract off the size of the textures. This makes the memory usage negative!
|
|
;; I don't understand why this happens, but
|
|
;; - it matches the game (texture size shows up as negative in the debug menu)
|
|
;; - the game sizes seem correct.
|
|
(let ((v1-7 (- (asize-of obj) (the-as int (shl (-> obj size) 2)))))
|
|
;; add 64-bytes for each entry, the size of texture.
|
|
(dotimes (a0-6 (-> obj length))
|
|
(if (-> obj data a0-6)
|
|
(+! v1-7 64)
|
|
)
|
|
)
|
|
;; update used and total.
|
|
(set! (-> arg0 data (mem-usage-id texture) used) (+ (-> arg0 data (mem-usage-id texture) used) v1-7))
|
|
;; total assumes 16-byte alignment.
|
|
(set! (-> arg0 data (mem-usage-id texture) total)
|
|
(+ (-> arg0 data (mem-usage-id texture) total) (logand -16 (+ v1-7 15)))
|
|
)
|
|
)
|
|
obj
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Texture Data Load
|
|
;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun texture-bpp ((arg0 gs-psm))
|
|
"Get the number of bits per pixel for the given texture format"
|
|
(let ((v1-0 arg0))
|
|
(cond
|
|
((= v1-0 (gs-psm mt8)) 8)
|
|
((= v1-0 (gs-psm mt4)) 4)
|
|
(else
|
|
(if (or (= v1-0 (gs-psm ct16))
|
|
(= v1-0 (gs-psm ct16s))
|
|
(= v1-0 (gs-psm mz16))
|
|
(= v1-0 (gs-psm mz16s))
|
|
)
|
|
16
|
|
32
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun texture-qwc ((w int) (h int) (tex-format gs-psm))
|
|
"Get the number of quadwords in a texture. Round up."
|
|
(let ((v1-0 (texture-bpp tex-format)))
|
|
(sar (+ (* (* w h) v1-0) 127) 7)
|
|
)
|
|
)
|
|
|
|
(defun physical-address ((arg0 pointer))
|
|
"Convert a pointer to a physical address than can be used for DMA"
|
|
(the-as pointer (logand #xfffffff (the-as int arg0)))
|
|
)
|
|
|
|
(defun dma-buffer-add-ref-texture ((buf dma-buffer) (data pointer) (tex-w int) (tex-h int) (tex-format gs-psm))
|
|
"Add texture data to a dma buffer. You must first set up the GS transfer to the correct destination.
|
|
This just sets IMAGE mode and sends data."
|
|
|
|
;; get pointer and size (quadwords)
|
|
(let ((data-ptr (physical-address data))
|
|
(qwc (texture-qwc tex-w tex-h tex-format))
|
|
)
|
|
;; do transfers until its all gone.
|
|
(while (> qwc 0)
|
|
;; only #x7fff quadwords/transfer is allowed.
|
|
(let ((qwc-this-time (min #x7fff qwc)))
|
|
;; is this the last transfer?
|
|
(let ((eop (if (= qwc qwc-this-time) 1 0)))
|
|
;; set up dma/vif for a single giftag
|
|
(let* ((a2-2 buf)
|
|
(setup-dma (the-as dma-packet (-> a2-2 base)))
|
|
)
|
|
(set! (-> setup-dma dma)
|
|
(new 'static 'dma-tag :qwc #x1 :id (dma-tag-id cnt))
|
|
)
|
|
(set! (-> setup-dma vif0) (new 'static 'vif-tag))
|
|
(set! (-> setup-dma vif1)
|
|
(new 'static 'vif-tag :imm #x1 :cmd (vif-cmd direct) :msk #x1)
|
|
)
|
|
(set! (-> a2-2 base) (&+ (the-as pointer setup-dma) 16))
|
|
)
|
|
|
|
;; set up IMAGE mode!
|
|
(let* ((a2-3 buf)
|
|
(setup-dif (the-as gs-gif-tag (-> a2-3 base)))
|
|
)
|
|
(set! (-> setup-dif tag) (new 'static 'gif-tag64 :flg #x2 :eop eop :nloop qwc-this-time))
|
|
(set! (-> setup-dif regs) (new 'static 'gif-tag-regs))
|
|
(set! (-> a2-3 base) (&+ (the-as pointer setup-dif) 16))
|
|
)
|
|
)
|
|
|
|
;; and send the data.
|
|
(let* ((a1-9 buf)
|
|
(data-dma (the-as dma-packet (-> a1-9 base)))
|
|
)
|
|
(set! (-> data-dma dma)
|
|
(new 'static 'dma-tag
|
|
:id (dma-tag-id ref)
|
|
:addr (the-as int data-ptr)
|
|
:qwc qwc-this-time
|
|
)
|
|
)
|
|
(set! (-> data-dma vif0) (new 'static 'vif-tag))
|
|
(set! (-> data-dma vif1)
|
|
(new 'static 'vif-tag :cmd (vif-cmd direct) :msk #x1 :imm qwc-this-time)
|
|
)
|
|
(set! (-> a1-9 base) (&+ (the-as pointer data-dma) 16))
|
|
)
|
|
|
|
;; seek to next data.
|
|
(&+! data-ptr (shl qwc-this-time 4))
|
|
(set! qwc (- qwc qwc-this-time))
|
|
)
|
|
)
|
|
)
|
|
(none)
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; texture
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; A texture stores some metadata about a single (possibly mipmapped) texture.
|
|
;; after load, these point to location of the texture in VRAM _if the texture were uploaded to address 0_.
|
|
;; these records will be updated to point to the correct spot in VRAM by the texture allocators.
|
|
|
|
(defmethod print texture ((obj texture))
|
|
"Print out texture object, describing the texture format."
|
|
(format #t "#<texture ~20S psm: ~6S ~4D x ~4D num-mips: ~D :size ~4DK "
|
|
(-> obj name)
|
|
(psm->string (-> obj psm))
|
|
(-> obj w)
|
|
(-> obj h)
|
|
(-> obj num-mips)
|
|
(shr (-> obj size) 8) ;; (vram words -> kb)
|
|
)
|
|
;; print each level
|
|
(dotimes (s5-1 (the-as int (-> obj num-mips)))
|
|
(format #t " #x~X/~X" (-> obj dest s5-1) (-> obj width s5-1))
|
|
)
|
|
;; for < 16 bpp textures, there is a color look-up table.
|
|
(if (< (texture-bpp (-> obj psm)) 16)
|
|
(format #t " :clut #x~X/1" (-> obj clutdest))
|
|
)
|
|
(format #t " @ #x~X>" obj)
|
|
obj
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Unused and partially broken texture format utils
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define ct32-24-block-table
|
|
(new 'static 'boxed-array :type int32 :length 32
|
|
0 1 4 5 16 17 20 21 2 3 6 7 18 19 22 23 8 9 12 13 24 25 28 29 10 11 14 15 26 27 30 31))
|
|
|
|
(define mz32-24-block-table
|
|
(new 'static 'boxed-array :type int32 :length 32
|
|
16 17 20 21 0 1 4 5 18 19 22 23 2 3 6 7 24 25 28 29 8 9 12 13 26 27 30 31 10 11 14 15))
|
|
|
|
(define ct16-block-table
|
|
(new 'static 'boxed-array :type int32 :length 32
|
|
0 2 8 10 1 3 9 11 4 6 12 14 5 7 13 15 16 18 24 26 17 19 25 27 20 22 28 30 21 23 29 31))
|
|
|
|
(define ct16s-block-table
|
|
(new 'static 'boxed-array :type int32 :length 32
|
|
0 2 16 18 1 3 17 19 8 10 24 26 9 11 25 27 4 6 20 22 5 7 21 23 12 14 28 30 13 15 29 31))
|
|
|
|
(define mz16-block-table
|
|
(new 'static 'boxed-array :type int32 :length 32
|
|
16 18 24 26 17 19 25 27 20 22 28 30 21 23 29 31 0 2 8 10 1 3 9 11 4 6 12 14 5 7 13 15))
|
|
|
|
(define mz16s-block-table
|
|
(new 'static 'boxed-array :type int32 :length 32
|
|
16 18 0 2 17 19 1 3 24 26 8 10 25 27 9 11 20 22 4 6 21 23 5 7 28 30 12 14 29 31 13 15))
|
|
|
|
(define mt8-block-table
|
|
(new 'static 'boxed-array :type int32 :length 32
|
|
0 1 4 5 16 17 20 21 2 3 6 7 18 19 22 23 8 9 12 13 24 25 28 29 10 11 14 15 26 27 30 31))
|
|
|
|
(define mt4-block-table
|
|
(new 'static 'boxed-array :type int32 :length 32
|
|
0 2 8 10 1 3 9 11 4 6 12 14 5 7 13 15 16 18 24 26 17 19 25 27 20 22 28 30 21 23 29 31))
|
|
|
|
(defun gs-find-block ((bx int) (by int) (tex-format gs-psm))
|
|
"Block index lookup."
|
|
(cond
|
|
((zero? tex-format)
|
|
(-> ct32-24-block-table (+ bx (shl by 3)))
|
|
)
|
|
((= tex-format (gs-psm ct24))
|
|
(-> ct32-24-block-table (+ bx (shl by 3)))
|
|
)
|
|
((= tex-format (gs-psm ct16))
|
|
(-> ct16-block-table (+ bx (shl by 2)))
|
|
)
|
|
((= tex-format (gs-psm ct16s))
|
|
(-> ct16s-block-table (+ bx (shl by 2)))
|
|
)
|
|
((= tex-format (gs-psm mz32))
|
|
(-> mz32-24-block-table (+ bx (shl by 3)))
|
|
)
|
|
((= tex-format (gs-psm mz24))
|
|
(-> mz32-24-block-table (+ bx (shl by 3)))
|
|
)
|
|
((= tex-format (gs-psm mz16))
|
|
(-> mz16-block-table (+ bx (shl by 2)))
|
|
)
|
|
((= tex-format (gs-psm mz16s))
|
|
(-> mz16s-block-table (+ bx (shl by 2)))
|
|
)
|
|
((= tex-format (gs-psm mt8))
|
|
(-> mt8-block-table (+ bx (shl by 3)))
|
|
)
|
|
((= tex-format (gs-psm mt4))
|
|
(-> mt4-block-table (+ bx (shl by 2)))
|
|
)
|
|
(else
|
|
0
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun gs-page-width ((arg0 gs-psm))
|
|
(let ((v1-0 arg0))
|
|
(if (or (zero? v1-0)
|
|
(= v1-0 (gs-psm ct24))
|
|
(= v1-0 (gs-psm ct16))
|
|
(= v1-0 (gs-psm ct16s))
|
|
)
|
|
64
|
|
(cond
|
|
((or (= v1-0 (gs-psm mt8)) (= v1-0 (gs-psm mt4)))
|
|
128
|
|
)
|
|
(else
|
|
(format #t "Warning: Unknown block width for psm ~D~%" arg0)
|
|
1
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun gs-page-height ((arg0 gs-psm))
|
|
(let ((v1-0 arg0))
|
|
(if (or (zero? v1-0) (= v1-0 (gs-psm ct24)))
|
|
32
|
|
(cond
|
|
((or (= v1-0 (gs-psm ct16)) (= v1-0 (gs-psm ct16s)))
|
|
64
|
|
)
|
|
((= v1-0 (gs-psm mt8))
|
|
64
|
|
)
|
|
((= v1-0 (gs-psm mt4))
|
|
128
|
|
)
|
|
(else
|
|
(format #t "Warning: Unknown block width for psm ~D~%" arg0)
|
|
1
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun gs-block-width ((arg0 gs-psm))
|
|
(let ((v1-0 arg0))
|
|
(if (or (zero? v1-0) (= v1-0 (gs-psm ct24)))
|
|
8
|
|
(cond
|
|
((or (= v1-0 (gs-psm ct16)) (= v1-0 (gs-psm ct16s)) (= v1-0 (gs-psm mt8)))
|
|
16
|
|
)
|
|
((= v1-0 (gs-psm mt4))
|
|
32
|
|
)
|
|
(else
|
|
(format #t "Warning: Unknown block width for psm ~D~%" arg0)
|
|
1
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun gs-block-height ((arg0 gs-psm))
|
|
(let ((v1-0 arg0))
|
|
(if (or (zero? v1-0)
|
|
(= v1-0 (gs-psm ct24))
|
|
(= v1-0 (gs-psm ct16))
|
|
(= v1-0 (gs-psm ct16s))
|
|
)
|
|
8
|
|
(cond
|
|
((or (= v1-0 (gs-psm mt8)) (= v1-0 (gs-psm mt4)))
|
|
16
|
|
)
|
|
(else
|
|
(format #t "Warning: Unknown block width for psm ~D~%" arg0)
|
|
1
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defun gs-largest-block ((tex-width int) (tex-height int) (tex-format gs-psm))
|
|
"Determine the largest block occupied by the given texture"
|
|
(let* ((block-width (gs-block-width tex-format))
|
|
(block-height (gs-block-height tex-format))
|
|
;; round up to neaest block.
|
|
(real-width
|
|
(* (/ (+ (+ block-width -1) tex-width) block-width) block-width)
|
|
)
|
|
(real-height
|
|
(* (/ (+ (+ block-height -1) tex-height) block-height) block-height)
|
|
)
|
|
;; and now convert to actual blocks
|
|
(width-blocks (/ real-width block-width))
|
|
(height-blocks (/ real-height block-height))
|
|
(max-block 0)
|
|
)
|
|
;; loop over each block...
|
|
(dotimes (x width-blocks)
|
|
(dotimes (y height-blocks)
|
|
;; and see where it is.
|
|
(set! max-block (max max-block (gs-find-block x y tex-format)))
|
|
)
|
|
)
|
|
max-block
|
|
)
|
|
)
|
|
|
|
(defun gs-blocks-used ((tex-width int) (tex-height int) (tex-format gs-psm))
|
|
"This function doesn't make much sense... It's unused so maybe it's just wrong?"
|
|
(let* ((page-width (gs-page-width tex-format))
|
|
(page-height (gs-page-height tex-format))
|
|
(real-width
|
|
(* (/ (+ (+ page-width -1) tex-width) page-width) page-width)
|
|
)
|
|
(real-height
|
|
(* (/ (+ (+ page-height -1) tex-height) page-height) page-height)
|
|
)
|
|
(width-blocks (/ real-width page-width))
|
|
(height-blocks (/ real-height page-height))
|
|
;; past here, it doesn't make much sense to me.
|
|
(a0-9 (- tex-width (* (+ width-blocks -1) page-width)))
|
|
(a1-7 (- tex-height (* (+ height-blocks -1) page-height)))
|
|
)
|
|
(if (or (< a0-9 page-width) (< a1-7 page-height))
|
|
(+
|
|
(+ (gs-largest-block a0-9 a1-7 tex-format) 1)
|
|
(shl (+ (* width-blocks height-blocks) -1) 5)
|
|
)
|
|
(shl (* height-blocks width-blocks) 5)
|
|
)
|
|
)
|
|
)
|
|
;;;;;;;;;;;;;; end of weird gs functions that are unused.
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Texture Pool
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; there is a single texture pool (*texture-pool*) that is responsible for
|
|
;; managing the textures in VRAM.
|
|
;; It can allocate plain memory, and also tracks "segments", which are just
|
|
;; chunks of VRAM that have a location+size.
|
|
|
|
(defmethod new texture-pool ((allocation symbol) (type-to-make type))
|
|
"Allocate and initialize a texture-pool"
|
|
(initialize!
|
|
(object-new allocation type-to-make (the-as int (-> type-to-make size)))
|
|
)
|
|
)
|
|
|
|
(defmethod allocate-vram-words! texture-pool ((obj texture-pool) (word-count int))
|
|
"Allocate words in vram. Returns the index of the first word."
|
|
(let ((v0-0 (-> obj cur)))
|
|
(set! (-> obj cur) (+ (-> obj cur) word-count))
|
|
v0-0
|
|
)
|
|
)
|
|
|
|
;; boot common textures are "common" textures that are loaded at boot, but will live in RAM
|
|
;; and be uploaded to VRAM as needed.
|
|
|
|
(defmethod lookup-boot-common-id texture-pool ((obj texture-pool) (arg0 int))
|
|
"Map these special textures to a number betwen 0 and 19. For other textures, return -1.
|
|
NOTE: hud means start menu + zoomer, not the usual health HUD."
|
|
(let ((v1-0 arg0))
|
|
(cond
|
|
((= v1-0 1032) 0) ;; hud (seg0 only)
|
|
((= v1-0 1119) 1) ;; zoomer-hud (not actually loaded at boot)
|
|
((= v1-0 1478) 2) ;; doesn't exist? (likely demo1)
|
|
((= v1-0 1485) 3) ;; demo2 (seg0 only)
|
|
((= v1-0 1486) 4) ;; demo3 (seg0 only)
|
|
((= v1-0 1487) 5) ;; demo4 (seg0 only)
|
|
(else
|
|
(cond
|
|
((or (= v1-0 635) (= v1-0 1609)) 6) ;; X or demo5j (seg0 only)
|
|
((= v1-0 636) 7) ;; nope
|
|
((= v1-0 637) 8) ;; nope
|
|
((= v1-0 752) 9) ;; nope
|
|
((= v1-0 1598) 10) ;; nope
|
|
((= v1-0 1599) 11) ;; demo2f
|
|
((= v1-0 1600) 12) ;; demo2g
|
|
((= v1-0 1601) 13) ;; demo2i
|
|
((= v1-0 1602) 14) ;; demo2s
|
|
((= v1-0 1603) 15) ;; demo4e
|
|
((= v1-0 1604) 16) ;; demo4f
|
|
((= v1-0 1605) 17) ;; demo4g
|
|
((= v1-0 1606) 18) ;; demo4i
|
|
((= v1-0 1607) 19) ;; demo4s
|
|
(else -1)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(defmethod initialize! texture-pool ((obj texture-pool))
|
|
"Initialize (or maybe reinitialize) a texture pool."
|
|
;; reset allocator
|
|
(set! (-> obj cur) 0)
|
|
;; I think top is basically unused.
|
|
(set! (-> obj top) (-> obj cur))
|
|
;; by default, use the default allocator.
|
|
(set! (-> obj allocate-func) texture-page-default-allocate)
|
|
;; allocate the weird stuff we always want (font, sky, etc)
|
|
(allocate-defaults! obj)
|
|
(set! (-> obj font-palette) (allocate-vram-words! obj 64))
|
|
|
|
;; clear out common pages.
|
|
(dotimes (v1-6 32)
|
|
(set! (-> obj common-page v1-6) (the-as texture-page 0))
|
|
)
|
|
(set! (-> obj common-page-mask) 0)
|
|
|
|
;; clear ids. This stores the texture ids that are stored at each "nd page", or 0 if there is junk.
|
|
;; it is used for the lazy loading system to see if the data is already there.
|
|
(dotimes (v1-9 160)
|
|
(set! (-> obj ids v1-9) (the-as uint 0))
|
|
)
|
|
obj
|
|
)
|
|
|
|
(defmethod get-leftover-block-count texture-page ((obj texture-page) (segment-count int) (additional-size int))
|
|
"This returns how many blocks are used in the last page nd-page.
|
|
It uses nd-pages, which are 64 blocks or 16 kB."
|
|
(let ((v1-0 additional-size))
|
|
(dotimes (a2-1 segment-count)
|
|
(+! v1-0 (the-as int (-> obj segment a2-1 size)))
|
|
)
|
|
(logand (sar v1-0 6) 63)
|
|
)
|
|
)
|
|
|
|
(defmethod print-usage texture-pool ((obj texture-pool))
|
|
"Print out VRAM usage."
|
|
(format #t "--------------------~%")
|
|
(format #t "texture pool ~DK - ~DK (~DK used, ~DK free)~%"
|
|
(sar (-> obj top) 8) ;; vram words to kb
|
|
(sar (-> obj cur) 8) ;; vram words to kb
|
|
(sar (- (-> obj cur) (-> obj top)) 8)
|
|
(sar (- #xfa000 (-> obj cur)) 8) ;; 4 MB, doesn't seem to account for framebuffers?
|
|
)
|
|
(format #t "--------------------~%")
|
|
obj
|
|
)
|
|
|
|
(defmethod allocate-segment! texture-pool ((obj texture-pool) (segment texture-pool-segment) (size int))
|
|
"Allocate a segment of the given size. The segment is an output here, containing size/dest."
|
|
(set! (-> segment size) (the-as uint size))
|
|
(set! (-> segment dest) (the-as uint (allocate-vram-words! obj size)))
|
|
segment
|
|
)
|
|
|
|
(defconstant NEAR_SEGMENT_WORDS #x62000) ;; ~1.6 MB
|
|
(defconstant COMMON_SEGMENT_WORDS #x1c000) ;; ~0.5 MB
|
|
(defconstant SPECIAL_VRAM_WORDS #x7000) ;; for sky, eyes, ocean, and depth-cue effect rendering.
|
|
|
|
(defmethod allocate-defaults! texture-pool ((obj texture-pool))
|
|
"Allocate default segments"
|
|
;; allocate the common and near segments
|
|
(allocate-segment! obj (-> obj segment-common) COMMON_SEGMENT_WORDS) ;; ~0.5 MB
|
|
(allocate-segment! obj (-> obj segment-near) NEAR_SEGMENT_WORDS) ;; ~1.6 MB.
|
|
(set! *sky-base-vram-word* (allocate-vram-words! obj SPECIAL_VRAM_WORDS))
|
|
(set! *sky-base-block* (sar *sky-base-vram-word* 6))
|
|
(set! *sky-base-page* (sar *sky-base-vram-word* 11))
|
|
(set! *eyes-base-vram-word* (+ *sky-base-vram-word* 6144))
|
|
(set! *eyes-base-block* (sar *eyes-base-vram-word* 6))
|
|
(set! *eyes-base-page* (sar *eyes-base-vram-word* 11))
|
|
(set! *ocean-base-vram-word* (+ *sky-base-vram-word* 6144))
|
|
(set! *ocean-base-block* (sar *ocean-base-vram-word* 6))
|
|
(set! *ocean-base-page* (sar *ocean-base-vram-word* 11))
|
|
(set! *depth-cue-base-vram-word* (+ *sky-base-vram-word* 6144))
|
|
(set! *depth-cue-base-block* (sar *depth-cue-base-vram-word* 6))
|
|
(set! *depth-cue-base-page* (sar *depth-cue-base-vram-word* 11))
|
|
(none)
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; texture-page management
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
(defmethod remove-from-heap texture-page ((obj texture-page) (seg kheap))
|
|
"Remove the texture data from the heap. This can only safely be called immediately after
|
|
the texture-page is loaded. This is used for textures that always live in VRAM."
|
|
(set! (-> seg current) (-> obj segment 0 block-data))
|
|
obj
|
|
)
|
|
|
|
(defun texture-page-default-allocate ((pool texture-pool) (page texture-page) (heap kheap) (tpage-id int))
|
|
"Default allocator for textures. This _permanently_ uploads the texture to VRAM and uses up VRAM that
|
|
can never be reclaimed, and does it immediately.
|
|
It modifies the texture to point to the allocated VRAM.
|
|
It also kicks out the texture data (and any data after it) from the heap.
|
|
All three segments of the texture page will be be together."
|
|
|
|
;; loop over the semgments in the texture page.
|
|
(dotimes (seg-id 3)
|
|
;; get vram for the segment
|
|
(let ((vram (allocate-vram-words! pool (the-as int (-> page segment seg-id size)))))
|
|
;; adjust the texture so it points to the vram address the allocator gave us.
|
|
(relocate-dests! page vram seg-id)
|
|
)
|
|
)
|
|
;; upload the texture page (all segments). This function will return after the upload has finished.
|
|
(upload-now! page -1)
|
|
;; and kick the data out from the heap, now that it is permanently in vram.
|
|
(remove-from-heap page heap)
|
|
page
|
|
)
|
|
|
|
|
|
(defun texture-page-common-allocate ((pool texture-pool) (page texture-page) (seg kheap) (tpage-id int))
|
|
"Set up an entire texture page for eventual upload to the common segment of the pool.
|
|
All three segments will be together."
|
|
|
|
;; bump allocator, starting at the beginning of the common segment.
|
|
;; the common segment is reused, so its fine that this overlaps with other textures using common.
|
|
(let ((s5-0 (-> pool segment-common dest)))
|
|
(dotimes (seg-id 3)
|
|
;; fixup texture data so it points to the right spot in the common segment.
|
|
(relocate-dests! page (the-as int s5-0) seg-id)
|
|
(+! s5-0 (-> page segment seg-id size))
|
|
)
|
|
)
|
|
page
|
|
)
|
|
|
|
(defun texture-page-common-boot-allocate ((pool texture-pool) (page texture-page) (heap kheap) (tpage-id int))
|
|
"Allocator for textures at boot time. It will put boot-common textures in common. Once it gets a non-common
|
|
texture, it will change the allocator to default."
|
|
|
|
;; see if we got a common texture. This will need to be reuploaded every time it is used.
|
|
(let ((tex-id (lookup-boot-common-id pool tpage-id)))
|
|
(cond
|
|
((>= tex-id 0)
|
|
;; let the common allocator deal with it.
|
|
(texture-page-common-allocate pool page heap tpage-id)
|
|
|
|
;; textures that:
|
|
;; - are in the common page (uploaded before use)
|
|
;; - are in common memory (not level-specific)
|
|
;; have a record in this common-page array.
|
|
;; this helps other code find the appropriate tpage to upload.
|
|
;; level-specific texture pages are stored in the level structure itself, but this doesn't apply here.
|
|
(set! (-> pool common-page tex-id) page)
|
|
)
|
|
(else
|
|
;; textures that aren't on that special list are permanently allocated.
|
|
;; once we get one default, switch the allocator to default for the rest.
|
|
(set! (-> *texture-pool* allocate-func) texture-page-default-allocate)
|
|
(texture-page-default-allocate pool page heap tpage-id)
|
|
)
|
|
)
|
|
)
|
|
page
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;
|
|
;; texture upload
|
|
;;;;;;;;;;;;;;;;;;
|
|
|
|
;; these functions generate DMA packets to configure the GS for upload
|
|
;; the dma-buffer-add-ref-textures function can then be used to actually send texture data.
|
|
|
|
(defun upload-vram-data ((buf dma-buffer) (dest int) (tex-data pointer) (tex-h int))
|
|
"Add DMA packet to prepare to upload a texture."
|
|
(while (> tex-h 0)
|
|
;; only 2048 height/transfer.
|
|
(let ((height-this-time (min 2048 tex-h)))
|
|
;; add dma/vif tag.
|
|
(let* ((v1-1 buf)
|
|
(dma (the-as dma-packet (-> v1-1 base)))
|
|
)
|
|
(set! (-> dma dma) (new 'static 'dma-tag :qwc #x5 :id (dma-tag-id cnt)))
|
|
(set! (-> dma vif0) (new 'static 'vif-tag))
|
|
(set! (-> dma vif1) (new 'static 'vif-tag :imm #x5 :cmd (vif-cmd direct) :msk #x1))
|
|
(set! (-> v1-1 base) (&+ (the-as pointer dma) 16))
|
|
)
|
|
|
|
;; add gif (a+d)
|
|
(let* ((v1-2 buf)
|
|
(gif (the-as gs-gif-tag (-> v1-2 base)))
|
|
)
|
|
(set! (-> gif tag) (new 'static 'gif-tag64 :nloop #x4 :nreg #x1))
|
|
(set! (-> gif regs) (new 'static 'gif-tag-regs :regs0 (gif-reg-id a+d)))
|
|
(set! (-> v1-2 base) (&+ (the-as pointer gif) 16))
|
|
)
|
|
|
|
;; add transfer setting registers
|
|
(let* ((v1-3 buf)
|
|
(gs-data (-> v1-3 base))
|
|
)
|
|
(set! (-> (the-as (pointer gs-bitbltbuf) gs-data) 0)
|
|
(new 'static 'gs-bitbltbuf :dbw #x2 :dbp dest)
|
|
)
|
|
(set! (-> (the-as (pointer gs-reg64) gs-data) 1) (gs-reg64 bitbltbuf))
|
|
(set! (-> (the-as (pointer gs-trxpos) gs-data) 2) (new 'static 'gs-trxpos))
|
|
(set! (-> (the-as (pointer gs-reg64) gs-data) 3) (gs-reg64 trxpos))
|
|
(set! (-> (the-as (pointer gs-trxreg) gs-data) 4)
|
|
(new 'static 'gs-trxreg :rrw #x80 :rrh height-this-time)
|
|
)
|
|
(set! (-> (the-as (pointer gs-reg64) gs-data) 5) (gs-reg64 trxreg))
|
|
(set! (-> (the-as (pointer gs-trxdir) gs-data) 6) (new 'static 'gs-trxdir))
|
|
(set! (-> (the-as (pointer gs-reg64) gs-data) 7) (gs-reg64 trxdir))
|
|
(set! (-> v1-3 base) (&+ gs-data 64))
|
|
)
|
|
(dma-buffer-add-ref-texture
|
|
buf
|
|
tex-data
|
|
128
|
|
height-this-time
|
|
(gs-psm ct32) ;; all uploads are ct32.
|
|
)
|
|
)
|
|
(+! dest 4096)
|
|
(set! tex-data (&+ tex-data #x100000))
|
|
(+! tex-h -2048)
|
|
)
|
|
(none)
|
|
)
|
|
|
|
(defun upload-vram-pages ((pool texture-pool) (segment texture-pool-segment) (page texture-page) (mode int) (bucket-idx int))
|
|
"Add a dma chain to upload textures to the bucket. This will only upload chunks that aren't already there.
|
|
This will automatically update the cache info in the pool for the upload.
|
|
mode: -3 = don't want anything (this function does nothing)
|
|
0 = page segment 0
|
|
-2 = page segment 0 and 1
|
|
-1 = the whole page.
|
|
2 = just segment 2 of the page."
|
|
(local-vars
|
|
(tex-data pointer)
|
|
(tex-dest-base-chunk uint)
|
|
(chunk-count uint)
|
|
(chunks-to-upload-count int)
|
|
(first-chunk-idx-to-upload int)
|
|
(tex-id uint)
|
|
)
|
|
(let ((total-upload-size 0))
|
|
(let* ((dma-buf (-> *display* frames (-> *display* on-screen) frame global-buf)) ;; the global DMA buffer
|
|
(dma-start (-> dma-buf base)) ;; the start of the DMA to add to the bucket.
|
|
)
|
|
|
|
;; default to segment 0 only (mode 0)
|
|
(set! tex-data (-> page segment 0 block-data)) ;; data to send, in EE memory
|
|
(set! tex-dest-base-chunk (shr (-> page segment 0 dest) 12)) ;; destination chunk idx.
|
|
(set! chunk-count (-> page segment 0 size)) ;; number of chunks in segment
|
|
(set! chunks-to-upload-count 0) ;; number of chunks to actually upload
|
|
(set! first-chunk-idx-to-upload 0) ;; index in data of first chunk to send
|
|
(set! tex-id (-> page id)) ;; the id of the texture.
|
|
(let ((v1-8 mode))
|
|
(cond
|
|
((= v1-8 -3)
|
|
(return 0) ;; mode -3, do nothing.
|
|
)
|
|
((zero? v1-8) ;; mode 0, default is okay
|
|
)
|
|
((= v1-8 -2) ;; mode -2, add on segment 1
|
|
(set! chunk-count (+ chunk-count (-> page segment 1 size)))
|
|
)
|
|
((= v1-8 -1) ;; mode -1, do the whole thing.
|
|
(set! chunk-count (-> page size))
|
|
)
|
|
((= v1-8 2) ;; mode 2, overwrite and do segment 2 only.
|
|
(set! tex-data (-> page segment 2 block-data))
|
|
(set! tex-dest-base-chunk (shr (-> page segment 2 dest) 12))
|
|
(set! chunk-count (-> page segment 2 size))
|
|
)
|
|
)
|
|
)
|
|
|
|
;; make sure we don't overflow the segment we're loading to.
|
|
(set! chunk-count
|
|
(the uint (shr (min (the-as int (-> segment size)) (the-as int (+ chunk-count 4095))) 12))
|
|
)
|
|
|
|
;; next, loop over each chunk to upload.
|
|
;; we want to:
|
|
;; - skip uploading chunks we already uploaded
|
|
;; - group together consecutive chunks we need to upload.
|
|
(dotimes (upload-chunk-idx (the-as int chunk-count))
|
|
;; the destination of the chunk.
|
|
(let ((current-dest-chunk
|
|
(+ tex-dest-base-chunk (the-as uint upload-chunk-idx))
|
|
)
|
|
)
|
|
;; now we see if we can get away with not uploading the chunk.
|
|
(if (zero? chunks-to-upload-count)
|
|
(when (!= (-> pool ids current-dest-chunk) tex-id)
|
|
;; we hit the beginning of a run of chunks that need uploading
|
|
(set! first-chunk-idx-to-upload upload-chunk-idx)
|
|
;; remember that we will upload this.
|
|
(set! (-> pool ids current-dest-chunk) tex-id)
|
|
(set! chunks-to-upload-count (+ chunks-to-upload-count 1))
|
|
)
|
|
(cond
|
|
;; in here, we are in the middle of a run of "needs uploading" chunks
|
|
((= (-> pool ids current-dest-chunk) tex-id)
|
|
;; and the run ends, we found a chunk that's already loaded.
|
|
;; so we upload the run:
|
|
(upload-vram-data dma-buf
|
|
(the int (shl (+ tex-dest-base-chunk (the-as uint first-chunk-idx-to-upload)) 6))
|
|
(&+ tex-data (shl first-chunk-idx-to-upload 14))
|
|
(shl chunks-to-upload-count 5)
|
|
)
|
|
(+! total-upload-size chunks-to-upload-count)
|
|
;; reset
|
|
(set! chunks-to-upload-count 0)
|
|
)
|
|
(else
|
|
;; the run continues!
|
|
(set! (-> pool ids current-dest-chunk) tex-id)
|
|
(set! chunks-to-upload-count (+ chunks-to-upload-count 1))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;; if we finished with a run of "needs upload", set up the upload.
|
|
(when (nonzero? chunks-to-upload-count)
|
|
(upload-vram-data
|
|
dma-buf
|
|
(the int (shl (+ tex-dest-base-chunk (the-as uint first-chunk-idx-to-upload)) 6))
|
|
(&+ tex-data (shl first-chunk-idx-to-upload 14))
|
|
(shl chunks-to-upload-count 5)
|
|
)
|
|
(+! total-upload-size chunks-to-upload-count)
|
|
)
|
|
|
|
;; do a texflush
|
|
|
|
;; first, set up dma/vif
|
|
(let* ((v1-47 dma-buf)
|
|
(dma (the-as dma-packet (-> v1-47 base)))
|
|
)
|
|
(set! (-> dma dma) (new 'static 'dma-tag :qwc #x2 :id (dma-tag-id cnt)))
|
|
(set! (-> dma vif0) (new 'static 'vif-tag))
|
|
(set!
|
|
(-> dma vif1)
|
|
(new 'static 'vif-tag :imm #x2 :cmd (vif-cmd direct) :msk #x1)
|
|
)
|
|
(set! (-> v1-47 base) (&+ (the-as pointer dma) 16))
|
|
)
|
|
|
|
;; and gif (a+d)
|
|
(let* ((v1-48 dma-buf)
|
|
(gif (the-as gs-gif-tag (-> v1-48 base)))
|
|
)
|
|
(set! (-> gif tag) (new 'static 'gif-tag64 :nloop #x1 :eop #x1 :nreg #x1))
|
|
(set!
|
|
(-> gif regs)
|
|
(new 'static 'gif-tag-regs
|
|
:regs0 (gif-reg-id a+d)
|
|
:regs1 (gif-reg-id a+d)
|
|
:regs2 (gif-reg-id a+d)
|
|
:regs3 (gif-reg-id a+d)
|
|
:regs4 (gif-reg-id a+d)
|
|
:regs5 (gif-reg-id a+d)
|
|
:regs6 (gif-reg-id a+d)
|
|
:regs7 (gif-reg-id a+d)
|
|
:regs8 (gif-reg-id a+d)
|
|
:regs9 (gif-reg-id a+d)
|
|
:regs10 (gif-reg-id a+d)
|
|
:regs11 (gif-reg-id a+d)
|
|
:regs12 (gif-reg-id a+d)
|
|
:regs13 (gif-reg-id a+d)
|
|
:regs14 (gif-reg-id a+d)
|
|
:regs15 (gif-reg-id a+d)
|
|
)
|
|
)
|
|
(set! (-> v1-48 base) (&+ (the-as pointer gif) 16))
|
|
)
|
|
|
|
;; texflush
|
|
(let* ((v1-49 dma-buf)
|
|
(gif-data (-> v1-49 base))
|
|
)
|
|
(set! (-> (the-as (pointer uint64) gif-data) 0) (the-as uint 1))
|
|
(set! (-> (the-as (pointer gs-reg64) gif-data) 1) (gs-reg64 texflush))
|
|
(set! (-> v1-49 base) (&+ gif-data 16))
|
|
)
|
|
|
|
;; we end the chain with a next. The bucket system will patch the next chain to this,
|
|
;; and then patch all the buckets togehter before sending the DMA.
|
|
(let ((a3-3 (-> dma-buf base)))
|
|
(let ((dma-end (the-as dma-packet (-> dma-buf base))))
|
|
(set! (-> dma-end dma) (new 'static 'dma-tag :id (dma-tag-id next)))
|
|
(set! (-> dma-end vif0) (new 'static 'vif-tag))
|
|
(set! (-> dma-end vif1) (new 'static 'vif-tag))
|
|
(set! (-> dma-buf base) (&+ (the-as pointer dma-end) 16))
|
|
)
|
|
(dma-bucket-insert-tag
|
|
(-> *display* frames (-> *display* on-screen) frame bucket-group)
|
|
bucket-idx
|
|
dma-start ;; the first thing in this chain, bucket will patch previous to this
|
|
(the-as (pointer dma-tag) a3-3) ;; end of this chain (ptr to next tag)
|
|
)
|
|
)
|
|
)
|
|
(shl total-upload-size 14)
|
|
)
|
|
)
|
|
|
|
(defun update-vram-pages ((pool texture-pool) (pool-segment texture-pool-segment) (page texture-page) (mode int))
|
|
"Update texture pool info if given texture page was uploaded in the given mode, but not using upload-vram-pages
|
|
or upload-vram-pages-pris
|
|
You should call this after doing an upload-now!, for example"
|
|
|
|
;; this is clearly copy-pasta from upload-vram-pages, and there are some weird leftovers.
|
|
(let ((v1-0 (-> page segment 0 block-data)))
|
|
)
|
|
|
|
(let ((dest-block (shr (-> page segment 0 dest) 12)) ;; where we're loading to
|
|
(sz (-> page segment 0 size))
|
|
(modified-chunk-count 0)
|
|
)
|
|
(let ((t0-0 0))
|
|
)
|
|
(let ((page-id (-> page id)))
|
|
(cond
|
|
((= mode -3)
|
|
(return 0) ;; do nothing
|
|
)
|
|
((zero? mode) ;; use segment 0
|
|
)
|
|
((= mode -2)
|
|
(+! sz (-> page segment 1 size)) ;; segment 0 + 1
|
|
)
|
|
((= mode -1)
|
|
(set! sz (-> page size)) ;; the whole page
|
|
)
|
|
((= mode 2) ;; segment 2 only
|
|
(let ((a3-5 (-> page segment 2 block-data)))
|
|
)
|
|
(set! dest-block (shr (-> page segment 2 dest) 12))
|
|
(set! sz (-> page segment 2 size))
|
|
)
|
|
)
|
|
|
|
;; don't overflow.
|
|
(let ((upload-chunks (shr (min (the-as int (-> pool-segment size)) (the-as int (+ sz 4095))) 12)))
|
|
|
|
;; for each chunk we might want to upload...
|
|
(dotimes (chunk-idx (the-as int upload-chunks))
|
|
;; this has the weird run logic, but it isn't really used.
|
|
;; no matter what (-> pool ids vram-chunk) will be set to page-id.
|
|
(let ((vram-chunk (+ dest-block (the-as uint chunk-idx))))
|
|
(if (zero? modified-chunk-count)
|
|
(when (!= (-> pool ids vram-chunk) page-id)
|
|
(set! (-> pool ids vram-chunk) page-id)
|
|
(+! modified-chunk-count 1)
|
|
)
|
|
(cond
|
|
((= (-> pool ids vram-chunk) page-id)
|
|
(set! modified-chunk-count 0)
|
|
)
|
|
(else
|
|
(set! (-> pool ids vram-chunk) page-id)
|
|
(+! modified-chunk-count 1)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
0
|
|
)
|
|
|
|
(defun upload-vram-pages-pris ((pool texture-pool) (segment texture-pool-segment) (page texture-page) (bucket-idx int) (allow-cache-mask int))
|
|
"Upload the entire texture page. If the allow-cache-mask is set for the chunk, it will not upload if there is already
|
|
the correct data. Upload will be added to the given bucket for on-screen.
|
|
The nth bit of the mask determines if the nth 16-kB chunk can safely use the existing data if the id check passes.
|
|
A 64-bit mask is enough to address the entire common segment, which is the only destination for PRIS textures."
|
|
(local-vars
|
|
(tex-data pointer)
|
|
(tex-dest-base-chunk uint)
|
|
(chunk-count uint)
|
|
(chunks-to-upload-count int)
|
|
(first-chunk-idx-to-upload int)
|
|
(page-id uint)
|
|
(current-dest-chunk uint)
|
|
(allow-cached symbol)
|
|
)
|
|
(let ((total-upload-size 0))
|
|
(let* ((dma-buf (-> *display* frames (-> *display* on-screen) frame global-buf))
|
|
(dma-start (-> dma-buf base))
|
|
)
|
|
(set! tex-data (-> page segment 0 block-data)) ;; data in RAM
|
|
(set! tex-dest-base-chunk (shr (-> page segment 0 dest) 12)) ;; where to load
|
|
(set! chunk-count (-> page size)) ;; how much to load
|
|
(set! chunks-to-upload-count 0) ;; for runs of uploads
|
|
(set! first-chunk-idx-to-upload 0) ;; for runs of uploads
|
|
(set! page-id (-> page id))
|
|
|
|
;; don't overflow.
|
|
(set! chunk-count (the uint (shr (min (the-as int (-> segment size)) (the-as int (+ chunk-count 4095))) 12)))
|
|
|
|
;; iterate through chunks to possibly upload
|
|
(dotimes (upload-chunk-idx (the-as int chunk-count))
|
|
;; where to load to
|
|
(set! current-dest-chunk
|
|
(+ tex-dest-base-chunk (the-as uint upload-chunk-idx))
|
|
)
|
|
;; can we possibly use existing data in VRAM?
|
|
(set! allow-cached
|
|
(nonzero? (logand allow-cache-mask (ash 1 upload-chunk-idx)))
|
|
)
|
|
;; look for the start of a run of uploads.
|
|
(if (zero? chunks-to-upload-count)
|
|
(when (and (!= (-> pool ids current-dest-chunk) page-id) allow-cached)
|
|
;; start of run!
|
|
(set! first-chunk-idx-to-upload upload-chunk-idx)
|
|
(set! (-> pool ids current-dest-chunk) page-id)
|
|
(set! chunks-to-upload-count (+ chunks-to-upload-count 1))
|
|
)
|
|
(cond
|
|
((or (= (-> pool ids current-dest-chunk) page-id) (not allow-cached))
|
|
;; end of run. upload the run.
|
|
(upload-vram-data dma-buf
|
|
(the int (shl (+ tex-dest-base-chunk (the-as uint first-chunk-idx-to-upload)) 6))
|
|
(&+ tex-data (shl first-chunk-idx-to-upload 14))
|
|
(shl chunks-to-upload-count 5)
|
|
)
|
|
(+! total-upload-size chunks-to-upload-count)
|
|
(set! chunks-to-upload-count 0)
|
|
)
|
|
(else
|
|
;; run continuing.
|
|
(set! (-> pool ids current-dest-chunk) page-id)
|
|
(set! chunks-to-upload-count (+ chunks-to-upload-count 1))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
;; if we ended in a run, upload it.
|
|
(when (nonzero? chunks-to-upload-count)
|
|
(upload-vram-data
|
|
dma-buf
|
|
(the int (shl (+ tex-dest-base-chunk (the-as uint first-chunk-idx-to-upload)) 6))
|
|
(&+ tex-data (shl first-chunk-idx-to-upload 14))
|
|
(shl chunks-to-upload-count 5)
|
|
)
|
|
(+! total-upload-size chunks-to-upload-count)
|
|
)
|
|
|
|
;; do a texflush.
|
|
(let* ((v1-52 dma-buf)
|
|
(dma (the-as dma-packet (-> v1-52 base)))
|
|
)
|
|
(set! (-> dma dma) (new 'static 'dma-tag :qwc #x2 :id (dma-tag-id cnt)))
|
|
(set! (-> dma vif0) (new 'static 'vif-tag))
|
|
(set! (-> dma vif1)
|
|
(new 'static 'vif-tag :imm #x2 :cmd (vif-cmd direct) :msk #x1)
|
|
)
|
|
(set! (-> v1-52 base) (&+ (the-as pointer dma) 16))
|
|
)
|
|
(let* ((v1-53 dma-buf)
|
|
(gif (the-as gs-gif-tag (-> v1-53 base)))
|
|
)
|
|
(set! (-> gif tag) (new 'static 'gif-tag64 :nloop #x1 :eop #x1 :nreg #x1))
|
|
(set!
|
|
(-> gif regs)
|
|
(new 'static 'gif-tag-regs
|
|
:regs0 (gif-reg-id a+d)
|
|
:regs1 (gif-reg-id a+d)
|
|
:regs2 (gif-reg-id a+d)
|
|
:regs3 (gif-reg-id a+d)
|
|
:regs4 (gif-reg-id a+d)
|
|
:regs5 (gif-reg-id a+d)
|
|
:regs6 (gif-reg-id a+d)
|
|
:regs7 (gif-reg-id a+d)
|
|
:regs8 (gif-reg-id a+d)
|
|
:regs9 (gif-reg-id a+d)
|
|
:regs10 (gif-reg-id a+d)
|
|
:regs11 (gif-reg-id a+d)
|
|
:regs12 (gif-reg-id a+d)
|
|
:regs13 (gif-reg-id a+d)
|
|
:regs14 (gif-reg-id a+d)
|
|
:regs15 (gif-reg-id a+d)
|
|
)
|
|
)
|
|
(set! (-> v1-53 base) (&+ (the-as pointer gif) 16))
|
|
)
|
|
(let* ((v1-54 dma-buf)
|
|
(a0-25 (-> v1-54 base))
|
|
)
|
|
(set! (-> (the-as (pointer uint64) a0-25) 0) (the-as uint 1))
|
|
(set! (-> (the-as (pointer gs-reg64) a0-25) 1) (gs-reg64 texflush))
|
|
(set! (-> v1-54 base) (&+ a0-25 16))
|
|
)
|
|
|
|
;; terminate the chain for the bucket.
|
|
(let ((a3-3 (-> dma-buf base)))
|
|
(let ((dma-end (the-as dma-packet (-> dma-buf base))))
|
|
(set! (-> dma-end dma) (new 'static 'dma-tag :id (dma-tag-id next)))
|
|
(set! (-> dma-end vif0) (new 'static 'vif-tag))
|
|
(set! (-> dma-end vif1) (new 'static 'vif-tag))
|
|
(set! (-> dma-buf base) (&+ (the-as pointer dma-end) 16))
|
|
)
|
|
|
|
;; add chain to bucket.
|
|
(dma-bucket-insert-tag
|
|
(-> *display* frames (-> *display* on-screen) frame bucket-group)
|
|
bucket-idx
|
|
dma-start
|
|
(the-as (pointer dma-tag) a3-3)
|
|
)
|
|
)
|
|
)
|
|
(shl total-upload-size 14)
|
|
)
|
|
)
|
|
|
|
|
|
;; NEAR segment layout:
|
|
|
|
;; ----------------------------------------------
|
|
;; | level 0 private | shared | level 1 private |
|
|
;; ----------------------------------------------
|
|
|
|
;; the textures for level 0 and level 1 may be as large as (sizeof private) + (sizeof shared).
|
|
;; the private sections remain in VRAM while the level is loaded, but the shared part is
|
|
;; reuploaded for each level on each frame.
|
|
|
|
;; the near allocators will only keep the shared part of the near data in RAM
|
|
;; NOTE: only segment 2 of the TFRAG texture page is NEAR.
|
|
|
|
(defun texture-page-near-allocate-0 ((pool texture-pool) (page texture-page) (heap kheap) (mode int))
|
|
"Allocator for tpages which use the near segment.
|
|
This is expected to be used on the first texture of a level load, the TFRAG.
|
|
Note: the zoomerhud texture may occur before this, but it's strange.
|
|
This is used for level 0, which gets the first part of the NEAR segment
|
|
as private texture memory."
|
|
|
|
;; set up segment 2 to be in the near segment
|
|
(relocate-dests! page (the-as int (-> pool segment-near dest)) 2)
|
|
|
|
;; segment 0, 1 go in common.
|
|
(let ((common-dest (-> pool segment-common dest)))
|
|
(dotimes (page-seg-idx 2)
|
|
(relocate-dests! page (the-as int common-dest) page-seg-idx)
|
|
(+! common-dest (-> page segment page-seg-idx size))
|
|
)
|
|
)
|
|
|
|
;; upload near data, and update the upload cache stuff.
|
|
(upload-now! page 2)
|
|
(update-vram-pages pool (-> pool segment-near) page 2)
|
|
|
|
;; our strategy is to remove the private memory from RAM.
|
|
;; to avoid leaving an unused hole, we copy the shared data backward.
|
|
;; unfortunately, it would be too slow to do it now.
|
|
;; this function runs during level loading, during the login of the linked tpage file.
|
|
;; the linker aims to use ~3% of a frame and limits itself to copies of up to ~600 kB
|
|
;; per frame. Copying back the near data may be slightly over 1 MB in the worst case,
|
|
;; and we've already used some time in the upload-now!, so we will delay the actual
|
|
;; copy until the next frame.
|
|
;; The level loader know about this, and all we have to do is set up *texture-reloate-later*
|
|
|
|
(let ((page-seg-2-size (logand -4096 (the-as int (+ (-> page segment 2 size) 4095)))))
|
|
(cond
|
|
((< (the-as uint #x24000) page-seg-2-size)
|
|
;; we use the shared memory of near.
|
|
|
|
;; this data should be kept in the heap
|
|
(let ((after-seg-2-data (+ #x90000 (the-as int (-> page segment 2 block-data)))))
|
|
(let ((seg-2-data (-> page segment 2 block-data)))
|
|
|
|
;; reduce size for the stuff that's in VRAM.
|
|
(set! (-> page segment 2 size) (+ -147456 (the-as int page-seg-2-size)))
|
|
|
|
;; adjust dest to upload past the "private" part, at the start of shared.
|
|
(set! (-> page segment 2 dest) (+ #x24000 (the-as int (-> pool segment-near dest))))
|
|
|
|
;; set the size of the heap as needed to hold only the unlocked texture data.
|
|
(set! (-> heap current)
|
|
(&+ (-> page segment 2 block-data) (shl (-> page segment 2 size) 2))
|
|
)
|
|
|
|
;; inform the level loader it should do this on the next frame.
|
|
(set! (-> *texture-relocate-later* memcpy) #t)
|
|
;; copy to the start of our data
|
|
(set! (-> *texture-relocate-later* dest) (the-as uint seg-2-data))
|
|
)
|
|
;; from the start of the unlocked data.
|
|
(set! (-> *texture-relocate-later* source) (the-as uint after-seg-2-data))
|
|
)
|
|
;; the number of bytes to copy.
|
|
(set! (-> *texture-relocate-later* move) (shl (-> page segment 2 size) 2))
|
|
)
|
|
(else
|
|
;; the whole thing fit in the locked near segment!
|
|
;; so we can just kick out segment 2 entirely and skip the memcpy stuff.
|
|
(set! (-> page segment 2 size) (the-as uint 0))
|
|
(set! (-> heap current) (-> page segment 2 block-data))
|
|
)
|
|
)
|
|
)
|
|
|
|
;; set the allocator to the common allocator for all other textures.
|
|
;; only TFRAG, the first page, uses near.
|
|
(set! (-> *texture-pool* allocate-func) texture-page-common-allocate)
|
|
;; in the level data, there is always code, then TFRAG texture,
|
|
;; so mark the code memory end as the start of this page.
|
|
(set! (-> *level* unknown-level-2 code-memory-end) (the-as uint page))
|
|
page
|
|
)
|
|
|
|
|
|
(defun texture-page-near-allocate-1 ((pool texture-pool) (page texture-page) (heap kheap) (mode int))
|
|
"Allocate for level 1's near textures"
|
|
|
|
;; effective size of segment 2, will go in near.
|
|
(let ((seg2-size (logand -4096 (the-as int (+ (-> page segment 2 size) 4095)))))
|
|
;; where to start our near data (somewhere in shared or level 1 private)
|
|
(let ((seg2-dest (+ (- #x62000 (the-as int seg2-size)) (-> pool segment-near dest))))
|
|
;; relocate to point to this point.
|
|
(relocate-dests! page (the-as int seg2-dest) 2)
|
|
)
|
|
|
|
;; set up other segments for the common segment.
|
|
(let ((common-dest (-> pool segment-common dest)))
|
|
(dotimes (page-seg-idx 2)
|
|
(relocate-dests! page (the-as int common-dest) page-seg-idx)
|
|
(+! common-dest (-> page segment page-seg-idx size))
|
|
)
|
|
)
|
|
|
|
;; upload the near data now.
|
|
(upload-now! page 2)
|
|
;; and remember it in the cache.
|
|
(update-vram-pages pool (-> pool segment-near) page 2)
|
|
|
|
(cond
|
|
((< (the-as uint #x24000) seg2-size)
|
|
;; we use the shared part. Kick out only the non-shared texture.
|
|
;; it's on th end this time, so no mempcy like in near-allocate-0
|
|
(set! (-> page segment 2 size) (+ -147456 (the-as int seg2-size)))
|
|
(set! (-> heap current)
|
|
(&+ (-> page segment 2 block-data) (shl (-> page segment 2 size) 2))
|
|
)
|
|
)
|
|
(else
|
|
;; we fit entirely in private. Kick out the whole thing!
|
|
(set! (-> page segment 2 size) (the-as uint 0))
|
|
(set! (-> heap current) (-> page segment 2 block-data))
|
|
)
|
|
)
|
|
)
|
|
(set! (-> *texture-pool* allocate-func) texture-page-common-allocate)
|
|
(set! (-> *level* unknown-level-2 code-memory-end) (the-as uint page))
|
|
page
|
|
)
|
|
|
|
|
|
(defun texture-page-level-allocate ((pool texture-pool) (page texture-page) (heap kheap) (mode int))
|
|
"Allocator for level textures."
|
|
(let ((common-id (lookup-boot-common-id pool mode)))
|
|
(cond
|
|
((>= common-id 0)
|
|
;; this will handle the zoomer HUD, which comes in before TFRAG.
|
|
(texture-page-common-allocate pool page heap mode)
|
|
(set! (-> pool common-page common-id) page)
|
|
)
|
|
(else
|
|
(let ((level-idx (-> *level* unknown-level-2 index)))
|
|
;; these will handle TFRAG. These allocators will then switch the allocator
|
|
;; to common for everything else.
|
|
(cond
|
|
((zero? level-idx)
|
|
(texture-page-near-allocate-0 pool page heap mode)
|
|
)
|
|
((= level-idx 1)
|
|
(texture-page-near-allocate-1 pool page heap mode)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
page
|
|
)
|
|
|
|
|
|
(defun texture-page-size-check ((pool texture-pool) (level level) (hide-prints symbol))
|
|
"Check to see if any texture are oversize. Sets bits in the output flag if they are"
|
|
(let ((oversize 0))
|
|
(let* ((tfrag-page (-> level texture-page 0))
|
|
(tfrag-mip0-size (-> tfrag-page mip0-size))
|
|
)
|
|
(when tfrag-page
|
|
(if (< (the-as uint #x3e000) tfrag-mip0-size)
|
|
(set! oversize (logior oversize 1))
|
|
)
|
|
(if (< (the-as uint #x1c000) (+ (-> tfrag-page segment 0 size) (-> tfrag-page segment 1 size)))
|
|
(set! oversize (logior oversize 1))
|
|
)
|
|
(when (not hide-prints)
|
|
(format #t "~Tlevel ~10S TFRAG tpage ~A uses ~DK of near ~DK~%"
|
|
(-> level name)
|
|
(-> tfrag-page name)
|
|
(shr tfrag-mip0-size 8)
|
|
992
|
|
)
|
|
(format #t "~Tlevel ~10S TFRAG tpage ~A uses ~DK of common ~DK~%"
|
|
(-> level name)
|
|
(-> tfrag-page name)
|
|
(shr (+ (-> tfrag-page segment 0 size) (-> tfrag-page segment 1 size)) 8)
|
|
448
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(let ((pris-page (-> level texture-page 1)))
|
|
(when pris-page
|
|
(if (< (the-as uint #x1c000) (-> pris-page size))
|
|
(set! oversize (logior oversize 2))
|
|
)
|
|
(if (not hide-prints)
|
|
(format #t "~Tlevel ~10S PRIS tpage ~A uses ~DK of common ~DK~%"
|
|
(-> level name)
|
|
(-> pris-page name)
|
|
(shr (-> pris-page size) 8)
|
|
448
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(let ((shrub-page (-> level texture-page 2)))
|
|
(when shrub-page
|
|
(if (< (the-as uint #x1c000) (-> shrub-page size))
|
|
(set! oversize (logior oversize 4))
|
|
)
|
|
(if (not hide-prints)
|
|
(format #t "~Tlevel ~10S SHRUB tpage ~A uses ~DK of common ~DK~%"
|
|
(-> level name)
|
|
(-> shrub-page name)
|
|
(shr (-> shrub-page size) 8)
|
|
448
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(let ((alpha-page (-> level texture-page 3)))
|
|
(when alpha-page
|
|
(if (< (the-as uint #x1c000) (-> alpha-page size))
|
|
(set! oversize (logior oversize 8))
|
|
)
|
|
(if (not hide-prints)
|
|
(format #t "~Tlevel ~10S ALPHA tpage ~A uses ~DK of common ~DK~%"
|
|
(-> level name)
|
|
(-> alpha-page name)
|
|
(shr (-> alpha-page size) 8)
|
|
448
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(let ((water-page (-> level texture-page 4)))
|
|
(when water-page
|
|
(if (< (the-as uint #x1c000) (-> water-page size))
|
|
(set! oversize (logior oversize 16))
|
|
)
|
|
(if (not hide-prints)
|
|
(format #t "~Tlevel ~10S WATER tpage ~A uses ~DK of common ~DK~%"
|
|
(-> level name)
|
|
(-> water-page name)
|
|
(shr (-> water-page size) 8)
|
|
448
|
|
)
|
|
)
|
|
)
|
|
)
|
|
oversize
|
|
)
|
|
)
|
|
|
|
|
|
(defmethod login-level-textures texture-pool ((obj texture-pool) (level level) (max-page-kind int) (id-array (pointer texture-id)))
|
|
"Login textures in a level. Only does up to max-page-kind. Set this to water (4) to do all of them.
|
|
Also checks sizes."
|
|
|
|
;; mark any existing as not loaded.
|
|
(dotimes (page-idx 9)
|
|
(set! (-> level texture-page page-idx) #f)
|
|
)
|
|
|
|
(if (>= max-page-kind 0) ;; tfrag.
|
|
;; login with near allocator.
|
|
(let ((tfrag-dir-entry (texture-page-login
|
|
(-> id-array 0)
|
|
(if (= (-> level index) 1)
|
|
texture-page-near-allocate-1
|
|
texture-page-near-allocate-0
|
|
)
|
|
loading-level
|
|
)
|
|
)
|
|
)
|
|
(if tfrag-dir-entry
|
|
(set! (-> level texture-page 0) (-> tfrag-dir-entry page))
|
|
)
|
|
)
|
|
)
|
|
|
|
(if (>= max-page-kind 1) ;; pris.
|
|
;; login with common.
|
|
(let ((pris-dir-entry (texture-page-login (-> id-array 1) texture-page-common-allocate loading-level)))
|
|
(if pris-dir-entry
|
|
(set! (-> level texture-page 1) (-> pris-dir-entry page))
|
|
)
|
|
)
|
|
)
|
|
(if (>= max-page-kind 2) ;; shrub.
|
|
(let ((shrub-dir-entry (texture-page-login (-> id-array 2) texture-page-common-allocate loading-level)))
|
|
(if shrub-dir-entry
|
|
(set! (-> level texture-page 2) (-> shrub-dir-entry page))
|
|
)
|
|
)
|
|
)
|
|
(if (>= max-page-kind 3)
|
|
(let ((alpha-dir-entry (texture-page-login (-> id-array 3) texture-page-common-allocate loading-level)))
|
|
(if alpha-dir-entry
|
|
(set! (-> level texture-page 3) (-> alpha-dir-entry page))
|
|
)
|
|
)
|
|
)
|
|
(if (>= max-page-kind 4)
|
|
(let ((water-dir-entry (texture-page-login (-> id-array 4) texture-page-common-allocate loading-level)))
|
|
(if water-dir-entry
|
|
(set! (-> level texture-page 4) (-> water-dir-entry page))
|
|
)
|
|
)
|
|
)
|
|
;; check with no prints first
|
|
(let ((overflow-bits (texture-page-size-check obj level #t)))
|
|
(when (nonzero? overflow-bits)
|
|
;; and if it failed, print info
|
|
(format #t "-------------------- tpage overflow error #x~X~%" overflow-bits)
|
|
(texture-page-size-check obj level #f)
|
|
(format #t "--------------------~%")
|
|
)
|
|
)
|
|
(none)
|
|
)
|
|
|
|
;; for movie hack.
|
|
(defun-extern movie? symbol)
|
|
|
|
(defmethod add-tex-to-dma! texture-pool ((obj texture-pool) (level level) (tex-page-kind int))
|
|
"For the given tpage-kind, upload as needed for the level"
|
|
(when (= tex-page-kind (tpage-kind tfrag)) ;; TFRAG (0)
|
|
;; get the texture page, bucket to add to, and an effective distance from the closest thing.
|
|
(let ((tfrag-page (-> level texture-page 0))
|
|
(tfrag-bucket (if (zero? (-> level index)) 5 12))
|
|
;; not really sure how this is calculated, but it's a distance.
|
|
(distance (fmin (fmin (-> level closest-object 0)
|
|
(if (and (< 0.0 (-> level level-distance))
|
|
(< (+ 409600.0 (-> level level-distance))
|
|
(-> level closest-object 5)
|
|
)
|
|
)
|
|
4095995904.0
|
|
(-> level closest-object 5)
|
|
)
|
|
)
|
|
(-> level closest-object 6)
|
|
)
|
|
)
|
|
)
|
|
(when tfrag-page
|
|
;; reset upload size counter.
|
|
(set! (-> level upload-size 0) 0)
|
|
|
|
;; near upload.
|
|
(if (< distance 81920.0)
|
|
(set! (-> level upload-size 0)
|
|
(+ (-> level upload-size 0)
|
|
(upload-vram-pages obj (-> obj segment-near) tfrag-page 2 tfrag-bucket)
|
|
)
|
|
)
|
|
)
|
|
(cond
|
|
((= distance 4095995904.0)) ;; not near at all, don't upload anything.
|
|
((< 102400.0 distance)
|
|
;; pretty far. Just do segment 0.
|
|
(set! (-> level upload-size 0)
|
|
(+ (-> level upload-size 0)
|
|
(upload-vram-pages obj (-> obj segment-common) tfrag-page 0 tfrag-bucket)
|
|
)
|
|
)
|
|
)
|
|
(else
|
|
;; pretty close. Do segment 0 and 1.
|
|
(set! (-> level upload-size 0)
|
|
(+ (-> level upload-size 0)
|
|
(upload-vram-pages obj (-> obj segment-common) tfrag-page -2 tfrag-bucket)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(if (= tex-page-kind (tpage-kind pris)) ;; PRIS (1)
|
|
(let ((pris-page (-> level texture-page 1)))
|
|
(if (and pris-page (nonzero? pris-page))
|
|
(let ((pris-bucket (if (zero? (-> level index)) 48 51)))
|
|
;; just upload the whole thing always.
|
|
;; use the cache mask as requested by the level.
|
|
(set! (-> level upload-size 1)
|
|
(upload-vram-pages-pris obj (-> obj segment-common) pris-page pris-bucket (the-as int (-> level texture-mask 7)))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(if (= tex-page-kind (tpage-kind shrub)) ;; SHRUB (2)
|
|
(let ((shrub-page (-> level texture-page 2))
|
|
(shrub-closest (-> level closest-object 2)) ;; I guess this is the shrub closest.
|
|
)
|
|
(if (and shrub-page (nonzero? shrub-page))
|
|
(let ((shrub-bucket (if (zero? (-> level index)) 19 25))
|
|
(shrub-mode (cond
|
|
((= shrub-closest 4095995904.0)
|
|
-3 ;; nothing
|
|
)
|
|
((< 102400.0 shrub-closest)
|
|
0 ;; seg 0
|
|
)
|
|
((< 81920.0 shrub-closest)
|
|
-2 ;; seg 0 and 1
|
|
)
|
|
(else
|
|
-1 ;; the whole thing.
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(set! (-> level upload-size 2)
|
|
(upload-vram-pages obj (-> obj segment-common) shrub-page shrub-mode shrub-bucket)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(if (= tex-page-kind (tpage-kind alpha)) ;; ALPHA (3)
|
|
(let ((alpha-page (-> level texture-page 3))
|
|
(alpha-closest (-> level closest-object 3))
|
|
)
|
|
(if (and alpha-page (nonzero? alpha-page))
|
|
(let ((alpha-bucket (if (zero? (-> level index)) 31 38))
|
|
(alpha-mode (cond
|
|
((< 348160.0 alpha-closest)
|
|
0 ;; segment 0
|
|
)
|
|
((< 163840.0 alpha-closest)
|
|
-2 ;; 0 and 1
|
|
)
|
|
(else
|
|
-1 ;; the whole thing.
|
|
)
|
|
)
|
|
)
|
|
)
|
|
(let ((alpha-dest-chunk (shr (-> alpha-page segment 0 dest) 12)))
|
|
;; there's some serious hack here. We invalidate some
|
|
;; alpha texture when in movie mode.
|
|
(when (movie?)
|
|
(set! (-> obj ids alpha-dest-chunk) (the-as uint 0))
|
|
(set! (-> obj ids (+ alpha-dest-chunk 1)) (the-as uint 0))
|
|
)
|
|
)
|
|
(set! (-> level upload-size 3)
|
|
(upload-vram-pages obj (-> obj segment-common) alpha-page alpha-mode alpha-bucket)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(if (= tex-page-kind (tpage-kind water)) ;; WATER (4)
|
|
(let ((water-page (-> level texture-page 4)))
|
|
(if (and water-page (nonzero? water-page))
|
|
(let ((water-bucket (if (zero? (-> level index)) 57 60)))
|
|
(set! (-> level upload-size 4)
|
|
(upload-vram-pages-pris obj (-> obj segment-common) water-page water-bucket (the-as int (-> level texture-mask 8)))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(none)
|
|
)
|