Archive/jak-project
1
0
Fork 0
mirror of https://github.com/open-goal/jak-project.git synced 2024-10-21 07:37:45 -04:00
Code Issues Actions Packages Projects Releases Wiki Activity
jak-project/goal_src/jak2/engine/gfx/texture/texture.gc
water111 df646282ab
[jak 2] fix texture lookup problem (#2373) 
This should fix a bunch of texture-related issues by generating a table
of overlapping textures and just... adjusting them slightly so they
don't overlap. It's not the most elegant solution in the world, but I
think it's no worse than the existing hard-coded tpage dir stuff.
2023-03-21 19:41:14 -04:00

2990 lines
109 KiB
Common Lisp
Raw Blame History

;;-*-Lisp-*-
(in-package goal)
;; name: texture.gc
;; name in dgo: texture
;; dgos: ENGINE, GAME
#|@file
Jak 2 texture system:
At a high level, the responsibility of the texture system is to make sure that each renderer
can use the textures it needs: the texture should be in VRAM at the right point in time, and
the renderer must know where the texture is in VRAM.
An oversimplified explanation is that each "bucket" in the rendering system needs a single
"texture page" (tpage) loaded into VRAM. Each level has a tpage for each category, where the
categories are:
tfrag (background tie/tfrag)
pris (foreground)
shrub (background shrub)
alpha
water
warp
pris2
sprite
map
sky
From the point of view of the rendering code, this oversimplification is basically true.
Renderers use textures by sending "adgif shaders" to the GS. These tell the GS how to use
the texture (mipmapping, size, format) and the location of the texture in VRAM (tbp).
When levels load, they must "log in" their adgif shaders with the texture system, and the texture
system will modify these in place so that things work.
However, behind the scenes, there are many tricks.
Texture data falls into two categories:
- boot
- common
"boot" textures are ones that are loaded on boot, transferred to VRAM, and live there forever.
"common" textures are ones that are loaded as they are needed. There's an area in VRAM
called the "common segment" that holds these.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
basic texture page methods
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
each "texture page" is a group of textures that are (from the point of view of renderers)
loaded all at once to vram, and contain all the textures needed for one category in one level.
however, the texture system does some tricks:
texture pages are divided into three "segments". The smaller number segments contain high
resolution mipmaps of textures (needed for close up), and the high number segments contain lower ones.
by looking at the distance to the closest object, we can figure out if the near textures
are needed or not, and skip segments if needed.
additionally, some texture pages have a chunk system that allows more specific control.
|#
(defmethod print texture-page ((obj texture-page))
"Print a texture page with name and size."
(format #t "#<texture-page ~S :length ~D :dest #x~X :size ~DK @ #x~X>"
(-> obj name)
(-> obj length)
(shr (-> obj segment 0 dest) 6)
(shr (+ (-> obj size) 255) 8)
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 bytes, of a texture-page.
Note that this does not include the texture objects, or the texture data."
(the-as int (+ (-> obj type size) (* (-> obj length) 4)))
)
(defmethod mem-usage texture-page ((obj texture-page) (arg0 memory-usage-block) (arg1 int))
"Get the amount of memory used by a texture page, including texture and texture data."
(set! (-> arg0 length) (max 83 (-> arg0 length)))
(set! (-> arg0 data 82 name) "texture")
(+! (-> arg0 data 82 count) (-> obj length))
;; note: in jak 1 this + was a - for reasons I do not understand.
(let ((v1-7 (+ (asize-of obj) (* (-> obj dram-size) 4))))
;; also add the size of the texture objects.
(dotimes (a0-6 (-> obj length))
(if (-> obj data a0-6)
(+! v1-7 112)
)
)
(+! (-> arg0 data 82 used) v1-7)
(+! (-> arg0 data 82 total) (logand -16 (+ v1-7 15)))
)
obj
)
;;;;;;;;;;;;;;;;;;;;;;;;;;
;; texture upload dma
;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun texture-bpp ((tex-fmt gs-psm))
"Get the number of bits per pixel for a texture format."
(case tex-fmt
(((gs-psm mt8))
8
)
(((gs-psm mt4))
4
)
(((gs-psm ct16) (gs-psm ct16s) (gs-psm mz16) (gs-psm mz16s))
16
)
(else
32
)
)
)
(defun texture-qwc ((width int) (height int) (tex-fmt gs-psm))
"Get the number of quadwords (16-bytes), rounded up, for a given texture size/format."
(let ((v1-0 (texture-bpp tex-fmt)))
(/ (+ (* (* width height) v1-0) 127) 128)
)
)
(defun physical-address ((ptr pointer))
"Convert a pointer (possibly to the uncached mapping) to a 'physical address' that "
(logand #xfffffff ptr)
)
(defun dma-buffer-add-ref-texture ((dma-buf dma-buffer) (tex-data-ptr pointer) (width int) (height int) (tex-fmt gs-psm))
"Add a texture upload to a dma buffer that refers to texture data.
This does not copy the texture data, but instead inserts a refernce.
This also assumes that the GS is currently set up for the right type of image upload."
(let ((padr (physical-address tex-data-ptr))
(qwc-remaining (texture-qwc width height tex-fmt))
)
;; break up transfer into 0x7fff quadword chunks.
(while (> qwc-remaining 0)
(let ((qwc-transfer (min #x7fff qwc-remaining)))
(let ((eop (if (= qwc-remaining qwc-transfer)
1
0
)
)
)
(let* ((a2-2 dma-buf)
(a3-1 (the-as object (-> a2-2 base)))
)
(set! (-> (the-as dma-packet a3-1) dma) (new 'static 'dma-tag :qwc #x1 :id (dma-tag-id cnt)))
(set! (-> (the-as dma-packet a3-1) vif0) (new 'static 'vif-tag))
(set! (-> (the-as dma-packet a3-1) vif1) (new 'static 'vif-tag :imm #x1 :cmd (vif-cmd direct) :msk #x1))
(set! (-> a2-2 base) (&+ (the-as pointer a3-1) 16))
)
(let* ((a2-3 dma-buf)
(a3-3 (the-as object (-> a2-3 base)))
)
(set! (-> (the-as gs-gif-tag a3-3) tag)
(new 'static 'gif-tag64 :flg (gif-flag image) :eop eop :nloop qwc-transfer)
)
(set! (-> (the-as gs-gif-tag a3-3) regs) (new 'static 'gif-tag-regs))
(set! (-> a2-3 base) (&+ (the-as pointer a3-3) 16))
)
)
(let* ((a1-9 dma-buf)
(a2-4 (the-as object (-> a1-9 base)))
)
(set! (-> (the-as dma-packet a2-4) dma)
(new 'static 'dma-tag :id (dma-tag-id ref) :addr (the-as int padr) :qwc qwc-transfer)
)
(set! (-> (the-as dma-packet a2-4) vif0) (new 'static 'vif-tag))
(set! (-> (the-as dma-packet a2-4) vif1)
(new 'static 'vif-tag :cmd (vif-cmd direct) :msk #x1 :imm qwc-transfer)
)
(set! (-> a1-9 base) (&+ (the-as pointer a2-4) 16))
)
(&+! padr (* qwc-transfer 16))
(set! qwc-remaining (- qwc-remaining qwc-transfer))
)
)
)
(none)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; basic texture methods
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; each texture is just some metadata about a texture, including its location in vram
;; and format settings.
(defmethod print texture ((obj texture))
(format #t "#<texture ~20S psm: ~6S ~4D x ~4D num-mips: ~D :size ~4DK "
(-> obj name)
(psm->string (-> obj psm)) ;; format
(-> obj w)
(-> obj h)
(-> obj num-mips)
(shr (-> obj size) 8)
)
;; print the location and size of each mip level
(dotimes (s5-1 (the-as int (-> obj num-mips)))
(format #t " #x~X/~X" (-> obj dest s5-1) (-> obj width s5-1))
)
;; print clut (color look up table) location in vram
(if (< (texture-bpp (-> obj psm)) 16)
(format #t " :clut #x~X/1" (-> obj clutdest))
)
(format #t " @ #x~X>" obj)
obj
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; texture memory layout
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The GS uses a crazy memory layout. Read the manual for more details.
;; these functions are wrong and unused, though the ct32-24-block-table is right
;; and used in the eye code.
(defun gs-find-block ((bx int) (by int) (fmt gs-psm))
(cond
((= fmt (gs-psm ct32))
(-> ct32-24-block-table (+ bx (* by 8)))
)
((= fmt (gs-psm ct24))
(-> ct32-24-block-table (+ bx (* by 8)))
)
((= fmt (gs-psm ct16))
(-> ct16-block-table (+ bx (* by 4)))
)
((= fmt (gs-psm ct16s))
(-> ct16s-block-table (+ bx (* by 4)))
)
((= fmt (gs-psm mz32))
(-> mz32-24-block-table (+ bx (* by 8)))
)
((= fmt (gs-psm mz24))
(-> mz32-24-block-table (+ bx (* by 8)))
)
((= fmt (gs-psm mz16))
(-> mz16-block-table (+ bx (* by 4)))
)
((= fmt (gs-psm mz16s))
(-> mz16s-block-table (+ bx (* by 4)))
)
((= fmt (gs-psm mt8))
(-> mt8-block-table (+ bx (* by 8)))
)
((= fmt (gs-psm mt4))
(-> mt4-block-table (+ bx (* by 4)))
)
(else
0
)
)
)
(defun gs-page-width ((arg0 gs-psm))
(case arg0
(((gs-psm ct32) (gs-psm ct24) (gs-psm ct16) (gs-psm ct16s))
64
)
(((gs-psm mt8) (gs-psm mt4))
128
)
(else
(format #t "Warning: Unknown block width for psm ~D~%" arg0)
1
)
)
)
(defun gs-page-height ((arg0 gs-psm))
(case arg0
(((gs-psm ct32) (gs-psm ct24))
32
)
(((gs-psm ct16) (gs-psm ct16s))
64
)
(((gs-psm mt8))
64
)
(((gs-psm mt4))
128
)
(else
(format #t "Warning: Unknown block width for psm ~D~%" arg0)
1
)
)
)
(defun gs-block-width ((arg0 gs-psm))
(case arg0
(((gs-psm ct32) (gs-psm ct24))
8
)
(((gs-psm ct16) (gs-psm ct16s) (gs-psm mt8))
16
)
(((gs-psm mt4))
32
)
(else
(format #t "Warning: Unknown block width for psm ~D~%" arg0)
1
)
)
)
(defun gs-block-height ((arg0 gs-psm))
(case arg0
(((gs-psm ct32) (gs-psm ct24) (gs-psm ct16) (gs-psm ct16s))
8
)
(((gs-psm mt8) (gs-psm mt4))
16
)
(else
(format #t "Warning: Unknown block width for psm ~D~%" arg0)
1
)
)
)
(defun gs-largest-block ((arg0 int) (arg1 int) (arg2 gs-psm))
(let* ((s5-0 (gs-block-width arg2))
(v1-0 (gs-block-height arg2))
(a0-6 (* (/ (+ s5-0 -1 arg0) s5-0) s5-0))
(a1-4 (* (/ (+ v1-0 -1 arg1) v1-0) v1-0))
(s5-1 (/ a0-6 s5-0))
(s3-1 (/ a1-4 v1-0))
(s4-1 0)
)
(dotimes (s2-0 s5-1)
(dotimes (s1-0 s3-1)
(set! s4-1 (max s4-1 (gs-find-block s2-0 s1-0 arg2)))
)
)
s4-1
)
)
(defun gs-blocks-used ((arg0 int) (arg1 int) (arg2 gs-psm))
(let* ((s4-0 (gs-page-width arg2))
(v1-0 (gs-page-height arg2))
(a0-6 (* (/ (+ s4-0 -1 arg0) s4-0) s4-0))
(a1-4 (* (/ (+ v1-0 -1 arg1) v1-0) v1-0))
(s3-0 (/ a0-6 s4-0))
(s1-0 (/ a1-4 v1-0))
(a0-9 (- arg0 (* (+ s3-0 -1) s4-0)))
(a1-7 (- arg1 (* (+ s1-0 -1) v1-0)))
)
(if (or (< a0-9 s4-0) (< a1-7 v1-0))
(+ (gs-largest-block a0-9 a1-7 arg2) 1 (* (+ (* s3-0 s1-0) -1) 32))
(* (* s1-0 s3-0) 32)
)
)
)
;;;;;;;;;;;;;;;;;
;; texture pool
;;;;;;;;;;;;;;;;;
;; the "texture-pool" is the global manager of textures.
;; among other things, it tracks which page is uploaded in each vram "page"
;; (confusingly a texture-page is many vram "pages" big)
;; The vram is divided into 128 vram pages, and the texture system will skip uploads
;; if a vram page already has the desired texture.
;; there are "default" textures, these only live in vram
;; "common" textures are just normal level textures that get uploaded as needed
;; "common-page" textures are common textures that the engine can easily request for
;; special cases, like displaying a splash screen.
(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))))
)
;; internally, the texture-pool has a bump allocator for vram. This assigns vram to various boot textures/segments
;; at boot time and isn't used at run-time. VRAM is often resued for multiple textures in a single frame,
;; and the common segment does more complicated management at runtime.
(defmethod allocate-vram-words! texture-pool ((obj texture-pool) (num-words int))
"Allocate the given number of vram words."
(let ((v0-0 (-> obj cur)))
(+! (-> obj cur) num-words)
v0-0
)
)
;; "common page"
;; The "common page" system is a weird way to have special hard-coded textures for the engine
;; for weird things like splash screens. These go in the common segment.
;; In jak 2, there are only 2 common page textures.
;; The "common" thing about these textures is that they are used by the engine directly, and
;; not any specific level/art-group.
;; So it's reasonable for them to hardcode tpage-ids here.
(defmethod get-common-page-slot-by-id texture-pool ((obj texture-pool) (tpage-id int))
"Check to see if the given tpage should go in the common page list.
If so, return the slot. Otherwise, return -1."
(case tpage-id
((33)
1
)
((34)
2
)
(else
-1
)
)
)
(defmethod initialize! texture-pool ((obj texture-pool))
"Initialize or reset the state of the texture-pool."
;; reset allocator
(set! (-> obj cur) 0)
(set! (-> obj top) (-> obj cur))
;; set the allocation function to default-allocate.
(set! (-> obj allocate-func) texture-page-default-allocate)
;; allocate some textures for effects, etc
(allocate-defaults obj)
;; allocate the font palette.
(format #t "font-palette start #x~x~%" (/ (-> obj cur) 64))
(set! (-> obj font-palette) (allocate-vram-words! obj 64))
(format #t "font-palette end #x~x~%" (/ (-> obj cur) 64))
;; reset common-page texture-pages
(dotimes (v1-8 32)
(set! (-> obj common-page v1-8) (the-as texture-page 0))
)
;; request no common-pages
(set! (-> obj common-page-mask) 0)
;; enable uploads for all textures
(set! (-> obj texture-enable-user-menu)
(texture-enable-mask tfrag pris shrub alpha water warp sprite map sky)
)
(set! (-> obj texture-enable-user) (texture-enable-mask tfrag pris shrub alpha water warp sprite map sky))
;; mark all vram slots as unoccupied.
(dotimes (v1-13 128)
(set! (-> obj ids v1-13) (the-as uint 0))
)
obj
)
(defmethod get-leftover-block-count texture-page ((obj texture-page) (num-segments int) (upload-offset int))
"Unused and somewhat useless function to figure out how many blocks we overflow into the next page.
This could be used with gs-largest-block to figure out how much of a page we use if we don't fit
exactly."
(let ((offset upload-offset))
(dotimes (i num-segments)
(+! offset (-> obj segment i size))
)
(logand (/ offset 64) 63)
)
)
(defmethod print-usage texture-pool ((obj texture-pool))
"Print out how much of a texture-pool is used.
This is not quite right because it does not count the frame or z buffer as used space."
(format #t "--------------------~%")
(format #t "texture pool ~DK - ~DK (~DK used, ~DK free)~%"
(/ (-> obj top) 256)
(/ (-> obj cur) 256)
(/ (- (-> obj cur) (-> obj top)) 256)
(/ (- #xfa000 (-> obj cur)) 256)
)
(format #t "--------------------~%")
obj
)
(defmethod allocate-segment texture-pool ((obj texture-pool) (seg texture-pool-segment) (num-words int))
"Assign vram to the given segment."
(set! (-> seg size) (the-as uint num-words))
(set! (-> seg dest) (the-as uint (allocate-vram-words! obj num-words)))
seg
)
(defmethod allocate-defaults texture-pool ((obj texture-pool))
"Assign vram for the texture system."
;; this "common" segment is about 1 MB and will hold basically all textures.
;; unlike jak 1, there's no near textures. instead, there's just a lot more uploads.
;; this seems like it would put a huge pressure on vram usage because these uploads
;; aren't free.
(format #t "texture start #x~x~%" (/ (-> obj cur) 64))
(allocate-segment obj (-> obj segment-common) #x3e000)
(format #t "texture end #x~x~%" (/ (-> obj cur) 64))
;; these "dynamic" textures are written to by renderers, and they have a fixed address.
;; notice that some of them overlap each other.
(set! (-> *ocean-envmap-texture-base* vram-word) (the-as uint (allocate-vram-words! obj #x9400)))
(set! (-> *ocean-envmap-texture-base* vram-block) (shr (-> *ocean-envmap-texture-base* vram-word) 6))
(set! (-> *ocean-envmap-texture-base* vram-page) (shr (-> *ocean-envmap-texture-base* vram-word) 11))
(set! (-> *ocean-texture-base* vram-word) (+ (-> *ocean-envmap-texture-base* vram-word) 4096))
(set! (-> *ocean-texture-base* vram-block) (shr (-> *ocean-texture-base* vram-word) 6))
(set! (-> *ocean-texture-base* vram-page) (shr (-> *ocean-texture-base* vram-word) 11))
(set! (-> *grey-scale-base* vram-word) (+ (-> *ocean-envmap-texture-base* vram-word) 4096))
(set! (-> *grey-scale-base* vram-block) (shr (-> *grey-scale-base* vram-word) 6))
(set! (-> *grey-scale-base* vram-page) (shr (-> *grey-scale-base* vram-word) 11))
(set! (-> *eyes-texture-base* vram-word) (+ (-> *ocean-envmap-texture-base* vram-word) 4096))
(set! (-> *eyes-texture-base* vram-block) (shr (-> *eyes-texture-base* vram-word) 6))
(set! (-> *eyes-texture-base* vram-page) (shr (-> *eyes-texture-base* vram-word) 11))
(set! (-> *map-texture-base* vram-word) (+ (-> *ocean-envmap-texture-base* vram-word) 4096))
(set! (-> *map-texture-base* vram-block) (shr (-> *map-texture-base* vram-word) 6))
(set! (-> *map-texture-base* vram-page) (shr (-> *map-texture-base* vram-word) 11))
(set! (-> *skull-gem-texture-base* vram-word) (+ #x9000 (-> *ocean-envmap-texture-base* vram-word)))
(set! (-> *skull-gem-texture-base* vram-block) (shr (-> *skull-gem-texture-base* vram-word) 6))
(set! (-> *skull-gem-texture-base* vram-page) (shr (-> *skull-gem-texture-base* vram-word) 11))
(format #t "dynamic end #x~x~%" (/ (-> obj cur) 64))
0
(none)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; texture page allocation
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; these functions assign texture-pages to vram.
;; unlike the functions above, these
;; - happen at runtime, as levels are loaded/unloaded.
;; - may assign multiple textures to the same vram address
;; it's ok for two textures to be mapped to the same vram address as
;; long as they are in different pages.
(defmethod remove-data-from-heap texture-page ((obj texture-page) (heap kheap))
"Remove a texture-page's data from main memory.
This is intended to be run on textures that are permanently in VRAM.
This only works if the texture-page was the last thing added to the heap,
and does NO checking to make sure this is the case.
The texture-page and texture records are kept (just metadata), the actual image data is discarded."
(set! (-> heap current) (-> obj segment 0 block-data))
obj
)
(defun texture-page-default-allocate ((pool texture-pool) (tpage texture-page) (heap kheap) (tpage-id int))
"Allocate a texture to be permanently stored in VRAM, and remove it from main memory.
This is only safe to call if the most recently loaded thing is this texture.
This will perform texture uploads, so this should not be called during drawing."
;; for each segment, permanently allocate VRAM
(dotimes (seg 3)
(let ((vram-loc (allocate-vram-words! pool (the-as int (-> tpage segment seg size)))))
;; and adjust the texture so it points to the allocated vram
(relocate-dests! tpage vram-loc seg)
)
)
;; load to VRAM
(upload-now! tpage (tex-upload-mode seg0-1-2))
;; and remove image data from main memory.
(remove-data-from-heap tpage heap)
;; for accurate accounting of memory
(set! (-> tpage dram-size) (the-as uint 0))
;; clear masks for each texture
(dotimes (tex-idx (-> tpage length))
(let ((tex (-> tpage data tex-idx)))
(when tex
(dotimes (mask-idx 3)
(dotimes (mask-word 3)
(set! (-> tex masks data mask-idx mask data mask-word) 0)
;(set! (-> (the-as texture (+ (+ (* mask-idx 16) (* mask-word 4)) (the-as int tex))) masks data 0 mask x) 0)
)
)
)
)
)
tpage
)
(defun texture-page-common-allocate ((pool texture-pool) (tpage texture-page) (heap kheap) (tpage-id int))
"Set up a texture that will be uploaded to VRAM as needed by the texture system.
These will go in the 'common' segment.
No upload is actually done."
(let ((vram-loc (-> pool segment-common dest)))
(dotimes (seg 3)
;; set up the VRAM address of the segment
(relocate-dests! tpage (the-as int vram-loc) seg)
;; don't put the segments on top of each other, they need to be spaced out
;; so they can be all loaded at once.
(+! vram-loc (-> tpage segment seg size))
)
)
;; this texture stays in main memory
;; and is uploaded again and again as needed
;; so the dram-size is the full size.
(set! (-> tpage dram-size) (-> tpage size))
tpage
)
(defun texture-page-font-allocate ((pool texture-pool) (tpage texture-page) (heap kheap) (tpage-id int))
"Special allocation for the font textures.
These are temporarily loaded to the common segment, then later moved."
;; set up their dest to go in common
(texture-page-common-allocate pool tpage heap tpage-id)
;; upload them to common segment now
(upload-now! tpage (tex-upload-mode seg0-1-2))
;; kick out of main memory now that they are in VRAM
(remove-data-from-heap tpage heap)
(set! (-> tpage dram-size) (the-as uint 0))
;; clear masks. is this actually needed for font?
(dotimes (tex-idx (-> tpage length))
(let ((tex (-> tpage data tex-idx)))
(when tex
(dotimes (mask-idx 3)
(dotimes (mask-word 3)
(set! (-> tex masks data mask-idx mask data mask-word) 0)
;(set! (-> (the-as texture (+ (+ (* mask-idx 16) (* mask-word 4)) (the-as int tex))) masks data 0 mask x) 0)
)
)
)
)
)
tpage
)
;;;;;;;;;;;;;;;;;;;;;;;;;
;; level combo set up
;;;;;;;;;;;;;;;;;;;;;;;;;
;; several renderers don't have separate buckets per level:
;; warp, hud, and sprite
;; so for these renderers, we need to make "combo" layouts where VRAM
;; is filled with pages from all levels.
;; For sprite and hud, it's the responsibility of the renderer to update adgifs to
;; point to new locations and levels are added/removed.
;; For warp, it's the responsibility of the texture system to update adgifs.
(defmethod lay-out-sprite-tex texture-pool ((obj texture-pool))
"Lay out sprite textures from all levels so all can fit into
VRAM at the same time."
;; this assumes that the common-segment starts at 0.
(let ((vram-loc 0))
;; loop over all active levels
(countdown (level-idx LEVEL_TOTAL)
(let ((lev (-> *level* level level-idx)))
(when (or (= (-> lev status) 'active)
(= (-> lev status) 'alive)
(= (-> lev status) 'loaded)
(= (-> lev status) 'reserved)
)
;; get the sprite tpage
(let ((tpage (-> lev texture-page 7)))
(when tpage
;; add each segment
(dotimes (seg 3)
(relocate-dests! tpage vram-loc seg)
(+! vram-loc (-> tpage segment seg size))
)
;; don't forget to align textures.
;; they do some tricks with segments to let them pack tightly,
;; but these can't be done here where the neighbor levels are unknown.
(set! vram-loc (shl (sar (+ vram-loc 4095) 12) 12))
)
)
)
)
;; check for out of memory.
(if (< #x3e000 vram-loc)
(format 0 "ERROR: Ran out of texture memory for SPRITE ~dk of 992k" (/ vram-loc 64))
)
)
)
0
(none)
)
(defmethod lay-out-hud-tex texture-pool ((obj texture-pool))
"Lay out hud/map textures from all levels so all can fit into
VRAM at the same time."
(let ((level-idx 0))
(countdown (vram-loc LEVEL_TOTAL)
(let ((lev (-> *level* level vram-loc)))
(when (or (= (-> lev status) 'active)
(= (-> lev status) 'alive)
(= (-> lev status) 'loaded)
(= (-> lev status) 'reserved)
)
(let ((tpage (-> lev texture-page 8)))
(when tpage
(dotimes (seg 3)
(relocate-dests! tpage level-idx seg)
(+! level-idx (-> tpage segment seg size))
)
(set! level-idx (shl (sar (+ level-idx 4095) 12) 12))
)
)
)
)
)
(if (< #x3e000 level-idx)
(format 0 "ERROR: Ran out of texture memory for HUD ~dk of 992k" (/ level-idx 64))
)
)
0
(none)
)
;; for warp, we do the same as above, but we also update all references to textures
;; to point to the new ones.
;; When levels load, they log in their adgifs (references to textures), which does two things:
;; - at login time, the adgif is adjusted to point to the texture.
;; - if the texture moves, the texture system can iterate through all adgifs referencing the texture
;; and update them. The texture system stores a linked list of adgifs per texture in the texture-page-dir.
(defmethod lay-out-warp-tex texture-pool ((obj texture-pool))
"Lay out warp textures from all levels so all can fit into
VRAM at the same time.
Also update all adgifs."
;; again, assume that common-segment starts at 0
(let ((vram-loc 0))
;; iterate over active levels
(countdown (level-idx LEVEL_TOTAL)
(let ((lev (-> *level* level level-idx)))
(when (or (= (-> lev status) 'active)
(= (-> lev status) 'alive)
(= (-> lev status) 'loaded)
(= (-> lev status) 'reserved)
)
;; get the warp tpage for this level
(let ((tpage (-> lev texture-page 5)))
(when tpage
;; the "base" address is the vram address of the start of this tpage
;; we're moving it from old to new. Initially, dest is 0, so this works
;; even on the first time
(let ((old-dest-base (-> tpage segment 0 dest))
(new-dest-base vram-loc)
)
;; loop over segments in tpage, assign them to unique vram
(dotimes (s1-0 3)
(relocate-dests! tpage vram-loc s1-0)
(+! vram-loc (-> tpage segment s1-0 size))
)
;; align after tpage (see note above)
(set! vram-loc (shl (sar (+ vram-loc 4095) 12) 12))
;; figure out how much tbp should be adjusted by. instead of figuring out tbp from scratch,
;; we can just adjust the current value (on the first run, this will assume each tpage is loaded at 0
;; because this is how they are logged in by the level system)
(let ((tbp-adjust (shr (- new-dest-base (the-as int old-dest-base)) 6)))
;; only if we actually move
(when (nonzero? tbp-adjust)
;; for each texture
(dotimes (texture-idx (-> tpage length))
;; grab the first adgif-shader by looking in *texture-page-dir* for this tpage and texture-idx.
;; the pointers don't store the lower 4 bits and assume 16-byte alignment for adgif-shader objects.
(let ((adgif-iter
(the-as
adgif-shader
(* (-> (the-as shader-ptr (-> *texture-page-dir* entries (-> tpage id) link next texture-idx)) shader) 16)
)
)
)
;; iterate through list, bumping tbp and cbp (clut vram addr)
(while (nonzero? (the-as uint adgif-iter))
(+! (-> adgif-iter tex0 tbp0) tbp-adjust)
(+! (-> adgif-iter tex0 cbp) tbp-adjust)
(set! adgif-iter (the-as adgif-shader (* (-> adgif-iter next shader) 16)))
)
)
)
)
)
)
)
)
)
)
)
(if (< #xa000 vram-loc)
(format 0 "ERROR: Ran out of texture memory for WARP ~dk of 160k" (/ vram-loc 64))
)
)
0
(none)
)
(defmethod clear-ids texture-pool ((obj texture-pool))
"Forget everything we have in VRAM and invalidate all caching
of common-segment textures."
;; this ids array tracks what the current texture-page loaded in each vram "chunk".
(dotimes (v1-0 128)
(set! (-> obj ids v1-0) (the-as uint 0))
)
0
(none)
)
(defmethod update-sprites texture-pool ((obj texture-pool))
"Redo the layout of sprite textures. This should be done when
a new level is added that needs new sprite textures, or a level
is unloaded and its sprite textures are no longer available."
;; assign texture to vram addresses
(lay-out-sprite-tex obj)
;; forget all previous ids, don't want to reuse the old sprite textures
;; as it may have the wrong layout.
(clear-ids obj)
;; flag that we no longer need to update this.
(set! (-> obj update-sprites-flag) #f)
(none)
)
(defmethod update-warp-and-hud texture-pool ((obj texture-pool))
"Redo the layout of warp/hud/map textures. This should be done when
a new level is added that needs new sprite textures, or a level
is unloaded and its sprite textures are no longer available."
(lay-out-hud-tex obj)
(lay-out-warp-tex obj)
(clear-ids obj)
(set! (-> obj update-flag) #f)
(none)
)
(defmethod mark-hud-warp-sprite-dirty texture-pool ((obj texture-pool))
"Mark that we should update sprite/warp/hud/map before the next use.
This should happen when any level is loaded/unloaded."
(set! (-> obj update-sprites-flag) #t)
(set! (-> obj update-flag) #t)
(none)
)
(defun texture-page-common-boot-allocate ((pool texture-pool) (tpage texture-page) (heap kheap) (tpage-id int))
"Set up texture that is loaded at boot."
;; first, see if it's a common-page texture.
(let ((common-page-slot-id (get-common-page-slot-by-id pool tpage-id)))
(cond
((>= common-page-slot-id 0)
;; if so, put it in the common-page.
(texture-page-common-allocate pool tpage heap tpage-id)
(set! (-> pool common-page common-page-slot-id) tpage)
)
;; these next cases check for "default-level" textures.
;; these are common-segment textures that are loaded at boot, and
;; stay with the "default-level" always.
((= tpage-id 917)
(texture-page-common-allocate pool tpage heap tpage-id)
(set! (-> *level* default-level texture-page 0) tpage)
)
((= tpage-id 918)
(texture-page-common-allocate pool tpage heap tpage-id)
(set! (-> *level* default-level texture-page 1) tpage)
)
((= tpage-id 1106)
(texture-page-common-allocate pool tpage heap tpage-id)
(set! (-> *level* default-level texture-page 4) tpage)
)
((= tpage-id 1141)
(texture-page-common-allocate pool tpage heap tpage-id)
(set! (-> *level* default-level texture-page 9) tpage)
)
((= tpage-id 12)
(texture-page-common-allocate pool tpage heap tpage-id)
(set! (-> *level* default-level texture-page 7) tpage)
)
((= tpage-id 1658)
(texture-page-common-allocate pool tpage heap tpage-id)
(set! (-> *level* default-level texture-page 8) tpage)
)
((= tpage-id 2841)
(texture-page-common-allocate pool tpage heap tpage-id)
(set! (-> *level* default-level texture-page 5) tpage)
)
((= tpage-id 2932)
(texture-page-common-allocate pool tpage heap tpage-id)
(set! (-> *level* default-level texture-page 2) tpage)
)
((= tpage-id 3219)
(texture-page-common-allocate pool tpage heap tpage-id)
(set! (-> *level* default-level texture-page 3) tpage)
)
((= tpage-id 3076)
(texture-page-font-allocate pool tpage heap tpage-id)
)
(else
;; this texture goes in VRAM permanently.
(set! (-> *texture-pool* allocate-func) texture-page-default-allocate)
(texture-page-default-allocate pool tpage heap tpage-id)
)
)
)
(set! (-> tpage dram-size) (-> tpage size))
tpage
)
;;;;;;;;;;;;;;;;;;
;; tpage upload
;;;;;;;;;;;;;;;;;;
;; these functions load tpages using the dma-buffer-add-ref-texture
;; and set up the GS for uploads.
;; the texture-pages are designed in a very special way that allows large uploads
;; to be chained together, so there is a bunch of logic to group together consecutive
;; uploads.
(defun upload-vram-data ((buf dma-buffer) (dest int) (data pointer) (height int) (width int))
"Generate DMA data to upload texture. This simply sets up a texture upload to happen in the future.
The texture data itself is referenced, not copied into the dma-buffer."
(while (> height 0)
(let ((height-this-time (min 2048 height)))
(let* ((v1-1 buf)
(a0-1 (the-as dma-packet (-> v1-1 base)))
)
(set! (-> a0-1 dma) (new 'static 'dma-tag :qwc #x5 :id (dma-tag-id cnt)))
(set! (-> a0-1 vif0) (new 'static 'vif-tag))
(set! (-> a0-1 vif1) (new 'static 'vif-tag :imm #x5 :cmd (vif-cmd direct) :msk #x1))
(set! (-> v1-1 base) (the-as pointer (&+ a0-1 16)))
)
(let* ((v1-2 buf)
(a0-3 (the-as gs-gif-tag (-> v1-2 base)))
)
(set! (-> a0-3 tag) (new 'static 'gif-tag64 :nloop #x1 :eop #x1 :nreg #x4))
(set! (-> a0-3 regs) GIF_REGS_ALL_AD)
(set! (-> v1-2 base) (the-as pointer (&+ a0-3 16)))
)
(let* ((v1-3 buf)
(a0-5 (-> v1-3 base))
)
(set! (-> (the-as (pointer gs-bitbltbuf) a0-5) 0) (new 'static 'gs-bitbltbuf :dbw (/ width 64) :dbp dest))
(set! (-> (the-as (pointer gs-reg64) a0-5) 1) (gs-reg64 bitbltbuf))
(set! (-> (the-as (pointer gs-trxpos) a0-5) 2) (new 'static 'gs-trxpos))
(set! (-> (the-as (pointer gs-reg64) a0-5) 3) (gs-reg64 trxpos))
(set! (-> (the-as (pointer gs-trxreg) a0-5) 4) (new 'static 'gs-trxreg :rrw width :rrh height-this-time))
(set! (-> (the-as (pointer gs-reg64) a0-5) 5) (gs-reg64 trxreg))
(set! (-> (the-as (pointer gs-trxdir) a0-5) 6) (new 'static 'gs-trxdir))
(set! (-> (the-as (pointer gs-reg64) a0-5) 7) (gs-reg64 trxdir))
(set! (-> v1-3 base) (&+ a0-5 64))
)
(dma-buffer-add-ref-texture buf data width height-this-time (gs-psm ct32))
)
(+! dest 4096)
(&+! data #x100000)
(+! height -2048)
)
(none)
)
(defun upload-vram-pages ((pool texture-pool)
(dest-seg texture-pool-segment)
(tpage texture-page)
(mode tex-upload-mode)
(bucket bucket-id)
)
"Build DMA for uploading the given texture-page, only uploading as needed."
(local-vars
(data-ptr pointer)
(vram-ptr uint)
(tpage-num-chunks int)
(chunks-pending int)
(first-chunk int)
(tpage-id uint)
)
(if (not tpage)
(return 0)
)
;; count total uploaded, for statistics
(let ((num-chunks 0))
(let* ((dma-buf (-> *display* frames (-> *display* on-screen) global-buf))
(s4-0 (-> dma-buf base))
)
;; the data in main memory to upload
(set! data-ptr (-> tpage segment 0 block-data))
;; where to send the data in VRAM
(set! vram-ptr (shr (-> tpage segment 0 dest) 12))
;; the total number of chunks we want to upload (assume just seg 0)
(set! tpage-num-chunks (the-as int (-> tpage segment 0 size)))
;; the number of chunks in a row to upload
(set! chunks-pending 0)
;; the index of the first chunk to upload in the combo above
(set! first-chunk 0)
(set! tpage-id (-> tpage id))
;; adjust based on the mode requested
(case mode
(((tex-upload-mode none))
;; why even bother...
(return 0)
)
(((tex-upload-mode seg0))
)
(((tex-upload-mode seg0-1))
;; add seg 1
(set! tpage-num-chunks (the-as int (+ tpage-num-chunks (-> tpage segment 1 size))))
)
(((tex-upload-mode seg0-1-2))
;; all segs
(set! tpage-num-chunks (the-as int (-> tpage size)))
)
(((tex-upload-mode seg2))
;; just seg2
(set! data-ptr (-> tpage segment 2 block-data))
(set! vram-ptr (shr (-> tpage segment 2 dest) 12))
(set! tpage-num-chunks (the-as int (-> tpage segment 2 size)))
)
)
;; align, and truncate if we would go past the segment max
(set! tpage-num-chunks (shr (min (the-as int (-> dest-seg size)) (the-as int (+ tpage-num-chunks 4095))) 12))
;; this loop builds runs of consecutive chunks.
(dotimes (s1-0 tpage-num-chunks)
;; where to put this chunk in vram
(let ((v1-28 (+ vram-ptr s1-0)))
(cond
((zero? chunks-pending) ;; nothing in the run:
;; doesn't match what's in vram. need to upload, so start a run.
(when (!= (-> pool ids v1-28) tpage-id)
(set! first-chunk s1-0)
(set! (-> pool ids v1-28) tpage-id)
(set! chunks-pending (+ chunks-pending 1))
)
)
;; otherwise, we have chunks pending.
;; and, in this case, we don't need to upload. so this breaks the combo
;; and we should upload whatever is pending.
((= (-> pool ids v1-28) tpage-id)
(upload-vram-data
dma-buf
(the-as int (* (+ vram-ptr first-chunk) 64))
(&+ data-ptr (shl first-chunk 14))
(* chunks-pending 32)
128
)
(+! num-chunks chunks-pending) ;; track total for stats
(set! chunks-pending 0)
0
)
(else
;; continue the run.
(set! (-> pool ids v1-28) tpage-id)
(set! chunks-pending (+ chunks-pending 1))
)
)
)
)
;; done looping, upload any remaining run.
(when (nonzero? chunks-pending)
(upload-vram-data
dma-buf
(the-as int (* (+ vram-ptr first-chunk) 64))
(&+ data-ptr (shl first-chunk 14))
(* chunks-pending 32)
128
)
(+! num-chunks chunks-pending)
)
;; add a texflush.
(let* ((v1-51 dma-buf)
(a0-24 (the-as dma-packet (-> v1-51 base)))
)
(set! (-> a0-24 dma) (new 'static 'dma-tag :qwc #x2 :id (dma-tag-id cnt)))
(set! (-> a0-24 vif0) (new 'static 'vif-tag))
(set! (-> a0-24 vif1) (new 'static 'vif-tag :imm #x2 :cmd (vif-cmd direct) :msk #x1))
(set! (-> v1-51 base) (the-as pointer (&+ a0-24 16)))
)
(let* ((v1-52 dma-buf)
(a0-26 (the-as gs-gif-tag (-> v1-52 base)))
)
(set! (-> a0-26 tag) (new 'static 'gif-tag64 :nloop #x1 :eop #x1 :nreg #x1))
(set! (-> a0-26 regs) GIF_REGS_ALL_AD)
(set! (-> v1-52 base) (the-as pointer (&+ a0-26 16)))
)
(let* ((v1-53 dma-buf)
(a0-28 (-> v1-53 base))
)
(set! (-> (the-as (pointer int64) a0-28) 0) 1)
(set! (-> (the-as (pointer gs-reg64) a0-28) 1) (gs-reg64 texflush))
(set! (-> v1-53 base) (&+ a0-28 16))
)
(#when PC_PORT
(dma-buffer-add-cnt-vif2 dma-buf 1 (new 'static 'vif-tag :cmd (vif-cmd pc-port)) (the-as vif-tag 3))
(dma-buffer-add-uint64 dma-buf tpage)
(dma-buffer-add-uint64 dma-buf mode)
)
(let ((a3-3 (-> dma-buf base)))
(let ((v1-54 (the-as dma-packet (-> dma-buf base))))
(set! (-> v1-54 dma) (new 'static 'dma-tag :id (dma-tag-id next)))
(set! (-> v1-54 vif0) (new 'static 'vif-tag))
(set! (-> v1-54 vif1) (new 'static 'vif-tag))
(set! (-> dma-buf base) (the-as pointer (&+ v1-54 16)))
)
(dma-bucket-insert-tag
(-> *display* frames (-> *display* on-screen) bucket-group)
bucket
s4-0
(the-as (pointer dma-tag) a3-3)
)
)
)
(shl num-chunks 14)
)
)
(defun update-vram-pages ((pool texture-pool) (dest-seg texture-pool-segment) (tpage texture-page) (mode tex-upload-mode))
"Copy-pasta version of the above function that just sets ids, but does no uploads."
(-> tpage segment 0 block-data)
(let ((vram-ptr (shr (-> tpage segment 0 dest) 12))
(tpage-num-chunks (-> tpage segment 0 size))
(chunks-pending 0)
)
0
(let ((tpage-id (-> tpage id)))
(cond
((= mode (tex-upload-mode none))
(return 0)
)
((= mode (tex-upload-mode seg0))
)
((= mode (tex-upload-mode seg0-1))
(+! tpage-num-chunks (-> tpage segment 1 size))
)
((= mode (tex-upload-mode seg0-1-2))
(set! tpage-num-chunks (-> tpage size))
)
((= mode (tex-upload-mode seg2))
(-> tpage segment 2 block-data)
(set! vram-ptr (shr (-> tpage segment 2 dest) 12))
(set! tpage-num-chunks (-> tpage segment 2 size))
)
)
(let ((adjusted-num-chunks (shr (min (the-as int (-> dest-seg size)) (the-as int (+ tpage-num-chunks 4095))) 12)))
(dotimes (chunk-idx adjusted-num-chunks)
(let ((chunk-ptr (+ vram-ptr chunk-idx)))
(cond
((zero? chunks-pending)
(when (!= (-> pool ids chunk-ptr) tpage-id)
(set! (-> pool ids chunk-ptr) tpage-id)
(+! chunks-pending 1)
)
)
((= (-> pool ids chunk-ptr) tpage-id)
(set! chunks-pending 0)
)
(else
(set! (-> pool ids chunk-ptr) tpage-id)
(+! chunks-pending 1)
)
)
)
)
)
)
)
0
)
(defun upload-vram-pages-pris-pc ((pool texture-pool)
(dest-seg texture-pool-segment)
(tpage texture-page)
(bucket bucket-id)
(mask (pointer int32))
)
"Build DMA for uploading the given texture-page in pc format.
We don't use the mask system of the original game properly."
(if (not tpage)
(return 0)
)
(let* ((dma-buf (-> *display* frames (-> *display* on-screen) global-buf))
(s4-0 (-> dma-buf base))
(any-uploads #f)
(vram-ptr (shr (-> tpage segment 0 dest) 12))
(tpage-num-chunks (the-as int (-> tpage size)))
(tpage-id (-> tpage id))
)
;; align and truncate
(set! tpage-num-chunks (shr (min (the-as int (-> dest-seg size)) (the-as int (+ tpage-num-chunks 4095))) 12))
;; loop over chunks, seeing if any need to be uploaded.
(dotimes (chunk-idx tpage-num-chunks)
(let ((mask-work (-> mask (/ chunk-idx 32))))
(when (logtest? mask-work (ash 1 (logand chunk-idx 31)))
(set! any-uploads #t)
)
)
)
;; not used at all. we don't set merc masks on PC, so this should happen most of the time.
; (when (not any-uploads)
; (return 0)
; )
;; but non-merc users of this function (like map/hud) will get here
;; upload everything in the tpage.
;; uploads are "free" on PC, so no harm, but we have to tell the game we're doing this
;; otherwise it might think that an old texture was left behind and skip a later upload
(dotimes (chunk-idx tpage-num-chunks)
(let ((chunk-dest (+ vram-ptr chunk-idx)))
(set! (-> pool ids chunk-dest) tpage-id)
)
)
;; tell pc port we upload everything.
(dma-buffer-add-cnt-vif2 dma-buf 1 (new 'static 'vif-tag :cmd (vif-cmd pc-port)) (the-as vif-tag 3))
(dma-buffer-add-uint64 dma-buf tpage)
(dma-buffer-add-uint64 dma-buf -1)
(let ((a3-5 (-> dma-buf base)))
(let ((v1-43 (the-as dma-packet (-> dma-buf base))))
(set! (-> v1-43 dma) (new 'static 'dma-tag :id (dma-tag-id next)))
(set! (-> v1-43 vif0) (new 'static 'vif-tag))
(set! (-> v1-43 vif1) (new 'static 'vif-tag))
(set! (-> dma-buf base) (the-as pointer (&+ v1-43 16)))
)
(dma-bucket-insert-tag
(-> *display* frames (-> *display* on-screen) bucket-group)
bucket
s4-0
(the-as (pointer dma-tag) a3-5)
)
)
)
0
)
(defun upload-vram-pages-pris ((pool texture-pool)
(dest-seg texture-pool-segment)
(tpage texture-page)
(bucket bucket-id)
(mask (pointer int32))
)
"Does nothing on PC.
Build DMA for uploading the given texture-page, only uploading as needed.
Unlike the normal upload-vram-pages, this just takes an array of mask bits,
and only uploads seg 0 (there is no upload mode).
See upload-vram-pages for some more details."
(local-vars
(data-ptr pointer)
(vram-ptr uint)
(tpage-num-chunks int)
(chunks-pending int)
(first-chunk int)
(tpage-id uint)
(should-upload symbol)
)
(if (not tpage)
(return 0)
)
(let ((total-chunks-uploaded 0))
(let* ((dma-buf (-> *display* frames (-> *display* on-screen) global-buf))
(s4-0 (-> dma-buf base))
)
(set! data-ptr (-> tpage segment 0 block-data))
(set! vram-ptr (shr (-> tpage segment 0 dest) 12))
(set! tpage-num-chunks (the-as int (-> tpage size)))
(set! chunks-pending 0)
(set! first-chunk 0)
(set! tpage-id (-> tpage id))
;; align and truncate
(set! tpage-num-chunks (shr (min (the-as int (-> dest-seg size)) (the-as int (+ tpage-num-chunks 4095))) 12))
;; loop over chunks, building runs of consecutive uploads.
(dotimes (chunk-idx tpage-num-chunks)
(let ((chunk-dest (+ vram-ptr chunk-idx)))
(let ((mask-work (-> mask (/ chunk-idx 32))))
(set! should-upload (logtest? mask-work (ash 1 (logand chunk-idx 31))))
)
(cond
((zero? chunks-pending)
(when (and (!= (-> pool ids chunk-dest) tpage-id) should-upload)
(set! first-chunk chunk-idx)
(set! (-> pool ids chunk-dest) tpage-id)
(set! chunks-pending (+ chunks-pending 1))
)
)
((or (= (-> pool ids chunk-dest) tpage-id) (not should-upload))
(upload-vram-data
dma-buf
(the-as int (* (+ vram-ptr first-chunk) 64))
(&+ data-ptr (shl first-chunk 14))
(* chunks-pending 32)
128
)
(+! total-chunks-uploaded chunks-pending)
(set! chunks-pending 0)
0
)
(else
(set! (-> pool ids chunk-dest) tpage-id)
(set! chunks-pending (+ chunks-pending 1))
)
)
)
)
(when (nonzero? chunks-pending)
(upload-vram-data
dma-buf
(the-as int (* (+ vram-ptr first-chunk) 64))
(&+ data-ptr (shl first-chunk 14))
(* chunks-pending 32)
128
)
(+! total-chunks-uploaded chunks-pending)
)
(let* ((v1-40 dma-buf)
(a0-27 (the-as dma-packet (-> v1-40 base)))
)
(set! (-> a0-27 dma) (new 'static 'dma-tag :qwc #x2 :id (dma-tag-id cnt)))
(set! (-> a0-27 vif0) (new 'static 'vif-tag))
(set! (-> a0-27 vif1) (new 'static 'vif-tag :imm #x2 :cmd (vif-cmd direct) :msk #x1))
(set! (-> v1-40 base) (the-as pointer (&+ a0-27 16)))
)
(let* ((v1-41 dma-buf)
(a0-29 (the-as gs-gif-tag (-> v1-41 base)))
)
(set! (-> a0-29 tag) (new 'static 'gif-tag64 :nloop #x1 :eop #x1 :nreg #x1))
(set! (-> a0-29 regs) GIF_REGS_ALL_AD)
(set! (-> v1-41 base) (the-as pointer (&+ a0-29 16)))
)
(let* ((v1-42 dma-buf)
(a0-31 (-> v1-42 base))
)
(set! (-> (the-as (pointer int64) a0-31) 0) 1)
(set! (-> (the-as (pointer gs-reg64) a0-31) 1) (gs-reg64 texflush))
(set! (-> v1-42 base) (&+ a0-31 16))
)
(let ((a3-5 (-> dma-buf base)))
(let ((v1-43 (the-as dma-packet (-> dma-buf base))))
(set! (-> v1-43 dma) (new 'static 'dma-tag :id (dma-tag-id next)))
(set! (-> v1-43 vif0) (new 'static 'vif-tag))
(set! (-> v1-43 vif1) (new 'static 'vif-tag))
(set! (-> dma-buf base) (the-as pointer (&+ v1-43 16)))
)
(dma-bucket-insert-tag
(-> *display* frames (-> *display* on-screen) bucket-group)
bucket
s4-0
(the-as (pointer dma-tag) a3-5)
)
)
)
(shl total-chunks-uploaded 14)
)
)
;;;;;;;;;;;;;;;;;
;; level texture
;;;;;;;;;;;;;;;;;
(defun texture-page-level-allocate ((pool texture-pool) (tpage texture-page) (heap kheap) (tpage-id int))
"Allocate function for level textures."
;; a bit of a hack: we assume that textures come immediately after the last code of a level,
;; so if we see that code-memory-end isn't set, set it here.
(if (zero? (-> *level* loading-level code-memory-end))
(set! (-> *level* loading-level code-memory-end) (the-as pointer tpage))
)
;; see if we got a common-page texture
(let ((common-page-slot-id (get-common-page-slot-by-id pool tpage-id)))
(cond
((>= common-page-slot-id 0)
;; we did! allocate as normal
(texture-page-common-allocate pool tpage heap tpage-id)
;; and add to common-page
(set! (-> pool common-page common-page-slot-id) tpage)
)
(else
;; otherwise just add like normal
;; note: unlike jak 1, there's no "near page" that levels use.
;; it's all in the common segment.
(texture-page-common-allocate pool tpage heap tpage-id)
)
)
)
tpage
)
(defun texture-page-size-check ((pool texture-pool) (lev level) (silent symbol))
"Check sizes for level textures, return a mask with a bit set for each failing tpage."
;; note that with jak 2's "combo" textures for warp/sprite/hud, we can't
;; detect out of VRAM until we actually we have all levels and try to layout the combo.
(let ((gp-0 0))
(let ((v1-0 (-> lev texture-page 0)))
(when v1-0
(if (< (the-as uint #x3e000) (-> v1-0 size))
(set! gp-0 (logior gp-0 1))
)
(if (not silent)
(format #t "~Tlevel ~10S TFRAG tpage ~A uses ~DK of common ~DK~%"
(-> lev name)
(-> v1-0 name)
(shr (-> v1-0 size) 8)
992
)
)
)
)
(let ((v1-2 (-> lev texture-page 1)))
(when v1-2
(if (< (the-as uint #x3e000) (-> v1-2 size))
(set! gp-0 (logior gp-0 2))
)
(if (not silent)
(format #t "~Tlevel ~10S PRIS tpage ~A uses ~DK of common ~DK~%"
(-> lev name)
(-> v1-2 name)
(shr (-> v1-2 size) 8)
992
)
)
)
)
(let ((v1-4 (-> lev texture-page 6)))
(when v1-4
(if (< (the-as uint #x3e000) (-> v1-4 size))
(set! gp-0 (logior gp-0 64))
)
(if (not silent)
(format #t "~Tlevel ~10S PRIS2 tpage ~A uses ~DK of common ~DK~%"
(-> lev name)
(-> v1-4 name)
(shr (-> v1-4 size) 8)
992
)
)
)
)
(let ((v1-6 (-> lev texture-page 2)))
(when v1-6
(if (< (the-as uint #x3e000) (-> v1-6 size))
(set! gp-0 (logior gp-0 4))
)
(if (not silent)
(format #t "~Tlevel ~10S SHRUB tpage ~A uses ~DK of common ~DK~%"
(-> lev name)
(-> v1-6 name)
(shr (-> v1-6 size) 8)
992
)
)
)
)
(let ((v1-8 (-> lev texture-page 3)))
(when v1-8
(if (< (the-as uint #x3e000) (-> v1-8 size))
(set! gp-0 (logior gp-0 8))
)
(if (not silent)
(format #t "~Tlevel ~10S ALPHA tpage ~A uses ~DK of common ~DK~%"
(-> lev name)
(-> v1-8 name)
(shr (-> v1-8 size) 8)
992
)
)
)
)
(let ((v1-10 (-> lev texture-page 4)))
(when v1-10
(if (< (the-as uint #x3e000) (-> v1-10 size))
(set! gp-0 (logior gp-0 16))
)
(if (not silent)
(format #t "~Tlevel ~10S WATER tpage ~A uses ~DK of common ~DK~%"
(-> lev name)
(-> v1-10 name)
(shr (-> v1-10 size) 8)
992
)
)
)
)
;; just print sizes.
(let ((v1-12 (-> lev texture-page 7)))
(when v1-12
(if (not silent)
(format #t "~Tlevel ~10S SPRITE tpage ~A uses ~DKK~%" (-> lev name) (-> v1-12 name) (shr (-> v1-12 size) 8))
)
)
)
(let ((v1-14 (-> lev texture-page 8)))
(when v1-14
(if (not silent)
(format #t "~Tlevel ~10S HUD tpage ~A uses ~DKK~%" (-> lev name) (-> v1-14 name) (shr (-> v1-14 size) 8))
)
)
)
(let ((v1-16 (-> lev texture-page 5)))
(when v1-16
(if (not silent)
(format #t "~Tlevel ~10S WARP tpage ~A uses ~DKK~%" (-> lev name) (-> v1-16 name) (shr (-> v1-16 size) 8))
)
)
)
gp-0
)
)
(defmethod login-level-textures texture-pool ((pool texture-pool) (lev level) (num-tpage-ids int) (tpage-ids (pointer texture-id)))
"After all tpages are loaded, call this function to set up level textures.
It'll call texture-page-login on each tpage, and set up texture-page field of level."
;; the properly set up texture pages will be stored here. for now, set to #f
(dotimes (v1-0 18)
(set! (-> lev texture-page v1-0) #f)
)
;; iterate through the tpage indices given to us by the bsp-header. There's one per tpage category.
;; we might have loaded texture in the wrong order, this will untangle that.
;; it'll also make sure that the login succeeds.
;; note that unlike jak 1, this won't call texture-page-login for texture-pages that we didn't get.
(dotimes (lev-tex-idx num-tpage-ids)
;; get the tpage-id in the bsp
(let ((tpage-id (-> tpage-ids lev-tex-idx)))
(when (and (nonzero? tpage-id) (< lev-tex-idx 18))
;; now loop through the tpages that were loaded as part of this level, and find one that matches:
(dotimes (loaded-tpage-idx (-> lev loaded-texture-page-count))
;; check for match
(when (= (-> lev loaded-texture-page loaded-tpage-idx id) (-> tpage-id page))
;; confirm that this tpage matches the one in the directory.
(let ((logged-in-tpage-id (texture-page-login tpage-id texture-page-common-allocate loading-level)))
;; if we got a successful login, and there tpage matches the bsp one
(if (and logged-in-tpage-id (= (-> logged-in-tpage-id page) (-> lev loaded-texture-page loaded-tpage-idx)))
;; so store it as successful!
(set! (-> lev texture-page lev-tex-idx) (-> logged-in-tpage-id page))
)
)
(goto cfg-20)
)
)
)
)
(label cfg-20)
)
;; check for oversize. if so print errors.
(let ((a2-3 (texture-page-size-check pool lev #t)))
(when (nonzero? a2-3)
(format #t "-------------------- tpage overflow error #x~X~%" a2-3)
(texture-page-size-check pool lev #f)
(format #t "--------------------~%")
)
)
0
(none)
)
(defmethod add-level-tpage-dma texture-pool ((pool texture-pool) (lev level) (cat tpage-category) (bucket bucket-id))
"Add dma to upload a tpage of a level."
(with-pp
;; get the tpage from the level
(let ((tpage (-> lev texture-page cat)))
;; closest object no longer used at all, it's all masks!
(-> lev closest-object-array cat)
(when (and tpage (nonzero? tpage))
(case cat ;; different logic for different categories
(((tpage-category tfrag))
;; I guess we have two categories here, grab both and or their masks.
(let ((v1-7 (-> lev texture-mask 0))
(a0-2 (-> lev texture-mask 11))
)
(dotimes (a1-1 3)
(logior! (-> v1-7 mask data a1-1) (-> a0-2 mask data a1-1))
)
)
;; upload with masks! the terribly named -pris function just means it takes a mask
;; instead of the old seg0,1,2 system.
(set! (-> lev upload-size 0) (upload-vram-pages-pris
pool
(-> pool segment-common)
tpage
bucket
(the-as (pointer int32) (-> lev texture-mask))
)
)
)
(((tpage-category shrub))
;; shrub: works just light tfrag
(let ((v1-11 (-> lev texture-mask 2))
(a0-6 (-> lev texture-mask 13))
)
(dotimes (a1-3 3)
(logior! (-> v1-11 mask data a1-3) (-> a0-6 mask data a1-3))
)
)
(set! (-> lev upload-size 2) (upload-vram-pages-pris
pool
(-> pool segment-common)
tpage
bucket
(the-as (pointer int32) (-> lev texture-mask 2))
)
)
)
(((tpage-category alpha))
;; alpha has some special cases
(cond
((= (-> lev index) LEVEL_MAX) ;; default level
;; if the auto-save-icon-flag is set, upload the alpha texture and clear flag.
(if (not (-> *bigmap* auto-save-icon-flag))
(set! (-> lev upload-size 8)
(upload-vram-pages pool (-> pool segment-common) tpage (tex-upload-mode seg0-1-2) bucket)
)
)
(set! (-> *bigmap* auto-save-icon-flag) #f)
)
(else
;; otherwise, use the usual logic.
(let ((t0-13 (-> lev texture-mask 3)))
(let ((v1-22 (-> lev texture-mask 14)))
(dotimes (a0-12 3)
(logior! (-> t0-13 mask data a0-12) (-> v1-22 mask data a0-12))
)
)
(set! (-> lev upload-size 3)
(upload-vram-pages-pris pool (-> pool segment-common) tpage bucket (the-as (pointer int32) t0-13))
)
)
)
)
)
(((tpage-category pris))
;; pris work like normal, but only 1 tpage.
(set! (-> lev upload-size 1) (upload-vram-pages-pris-pc
pool
(-> pool segment-common)
tpage
bucket
(the-as (pointer int32) (-> lev texture-mask 12))
)
)
)
(((tpage-category water))
;; water is like normal, 1 tpage.
(let ((t0-15 (-> lev texture-mask 4)))
(let ((v1-27 (-> lev texture-mask 15)))
(dotimes (a0-19 3)
(logior! (-> t0-15 mask data a0-19) (-> v1-27 mask data a0-19))
)
)
(set! (-> lev upload-size 4)
(upload-vram-pages-pris pool (-> pool segment-common) tpage bucket (the-as (pointer int32) t0-15))
)
)
)
(((tpage-category warp))
;; warp has no masks, just uploads all
(set! (-> lev upload-size 5)
(upload-vram-pages pool (-> pool segment-common) tpage (tex-upload-mode seg0-1-2) bucket)
)
)
(((tpage-category pris2))
;; pris2 is normal, 1 tpage.
(set! (-> lev upload-size 6) (upload-vram-pages-pris-pc
pool
(-> pool segment-common)
tpage
bucket
(the-as (pointer int32) (-> lev texture-mask 17))
)
)
)
(((tpage-category sprite))
;; sprite skips uploads if the level isn't drawing, but otherwise uploads the whole thing.
(when (or (= (-> lev display?) 'display) (= (-> lev display?) 'actor) (= (-> lev index) LEVEL_MAX))
(set! (-> lev upload-size 7)
(upload-vram-pages pool (-> pool segment-common) tpage (tex-upload-mode seg0-1-2) bucket)
)
)
)
(((tpage-category map))
;; map doesn't use masks for the default level.
(cond
((= (-> lev index) LEVEL_MAX)
(set! (-> lev upload-size 8)
(upload-vram-pages pool (-> pool segment-common) tpage (tex-upload-mode seg0-1-2) bucket)
)
)
(else
(let ((t0-20 (-> lev texture-mask cat)))
(set! (-> lev upload-size 8)
(upload-vram-pages-pris-pc pool (-> pool segment-common) tpage bucket (the-as (pointer int32) t0-20))
)
)
)
)
)
(((tpage-category sky))
;; sky uploads the whole thing.
(set! (-> lev upload-size 9)
(upload-vram-pages pool (-> pool segment-common) tpage (tex-upload-mode seg0-1-2) bucket)
)
)
)
;; next, update anims, if needed
(let ((s2-0 (-> lev texture-anim-array cat)))
(cond
((= cat (tpage-category warp))
;; warps put all their update-texture-anim's with the default level:
(when (= (-> lev index) LEVEL_MAX)
(dotimes (s2-1 LEVEL_TOTAL)
(let ((v1-54 (-> *level* level s2-1)))
(when (or (= (-> v1-54 status) 'active) (= (-> v1-54 status) 'reserved))
(if (-> v1-54 texture-anim-array 5)
(update-texture-anim bucket)
)
)
)
)
)
)
((= cat (tpage-category sky))
;; hack for a certain level here...
(cond
((and (level-get-target-inside *level*) (= (-> (level-get-target-inside *level*) info taskname) 'nest))
(let ((f30-0 (-> pp clock seconds-per-frame)))
(set! (-> pp clock seconds-per-frame) (* 10.0 (-> pp clock seconds-per-frame)))
(if s2-0
(update-texture-anim bucket)
)
(set! (-> pp clock seconds-per-frame) f30-0)
)
)
(else
(if s2-0
(update-texture-anim bucket)
)
)
)
)
(else
;; otherwise, just update if there's any anims.
(if s2-0
(update-texture-anim bucket)
)
)
)
)
)
)
;; unclear what can set these yet, but levels can request that certain vram is dirty
(let ((v1-77 (-> lev texture-dirty-masks cat)))
(dotimes (a0-58 128)
(let ((a2-2 (-> v1-77 mask data (/ a0-58 32))))
(when (logtest? a2-2 (ash 1 (logand a0-58 31)))
(set! (-> pool ids a0-58) (the-as uint 0))
0
)
)
)
(set! (-> v1-77 mask quad) (the-as uint128 0))
)
0
0
(none)
)
)
(defun set-skull-gem-masks ()
"Set the default-level texture-mask to include masks from three skull gem textures."
(local-vars (v0-3 uint128) (v1-2 uint128) (v1-3 uint128))
(let ((gp-0 (-> *level* default-level texture-mask)))
(let* ((s5-0 (lookup-texture-by-id (new 'static 'texture-id :index #x28 :page #x395)))
(s4-0 (lookup-texture-by-id (new 'static 'texture-id :index #x25 :page #x395)))
(a0-4 (lookup-texture-by-id (new 'static 'texture-id :index #x26 :page #x395)))
(v1-1 (-> gp-0 0 mask quad))
(a1-0 (-> s5-0 masks data 0 mask quad))
(a2-0 (-> s4-0 masks data 0 mask quad))
(a0-5 (-> a0-4 masks data 0 mask quad))
)
(.por v1-2 v1-1 a1-0)
(.por v1-3 v1-2 a2-0)
(.por v0-3 v1-3 a0-5)
)
(set! (-> gp-0 0 mask quad) v0-3)
)
(none)
)
(defun upload-textures ((arg0 texture-pool))
"Build DMA for all texture uploads.
This should be called after all drawing is done and all masks/distances are set."
;; set up skull-gem stuff, not yet understood
(cond
((not (-> *blit-displays-work* screen-copied))
(set-skull-gem-masks)
(set! (-> *level* default-level texture-anim-array 0) *skull-gem-texture-anim-array*)
)
(else
(set! (-> *level* default-level texture-anim-array 0) #f)
)
)
;; clear upload-size
(dotimes (lev-idx LEVEL_TOTAL)
(let ((lev (-> *level* level lev-idx)))
(when (or (= (-> lev status) 'active) (= (-> lev status) 'reserved))
(dotimes (a1-6 18)
(set! (-> lev upload-size a1-6) 0)
)
)
)
)
;; loop over tpages, using texture-page-translate to get all of them.
(dotimes (num-tpage (-> *texture-page-translate* length))
(let* ((tpage-info (-> *texture-page-translate* num-tpage))
(src-level (-> *level* draw-level (-> tpage-info level-index)))
)
(when (= num-tpage 63) ;; ??
(nop!)
(nop!)
0
)
(when (and src-level (logtest? (-> *texture-pool* texture-enable-user) (-> tpage-info texture-user)))
(cond
((= (-> tpage-info level-index) LEVEL_MAX)
;; always upload default-level textures
(add-level-tpage-dma
arg0
src-level
(the-as tpage-category (-> tpage-info level-texture-page))
(-> tpage-info bucket)
)
)
(else
;; otherwise, only upload level textures if not in mneu-mode.
(if (not (-> *blit-displays-work* menu-mode))
(add-level-tpage-dma
arg0
src-level
(the-as tpage-category (-> tpage-info level-texture-page))
(-> tpage-info bucket)
)
)
)
)
)
)
)
;; reset masks and closest array for the next frame!
(dotimes (v1-16 LEVEL_TOTAL)
(let ((a0-30 (-> *level* level v1-16)))
(when (or (= (-> a0-30 status) 'active) (= (-> a0-30 status) 'reserved))
(dotimes (a1-15 18)
(set! (-> a0-30 closest-object-array a1-15) 4095996000.0)
(set! (-> a0-30 texture-mask a1-15 mask quad) (the-as uint128 0))
)
)
)
)
0
(none)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; texture DMA outside of main DMA list
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; there are a few places at boot where we need to do uploads/copies
;; without using the main DMA list.
;; to hold the dma chain - doesn't hold textures, just DMA :ref tags and similar.
(kmemopen global "texture-dma-buffers")
(define *txt-dma-list* (new 'global 'dma-buffer 4096))
(kmemclose)
(defmethod upload-now! texture-page ((obj texture-page) (arg0 tex-upload-mode))
"Send the given texture-page to VRAM right now. This function doesn't return until
it has happened, and only should be used during boot."
(#when PC_PORT
;; load it to the PC Port's texture pool.
(__pc-texture-upload-now obj arg0)
)
(let ((gp-0 *txt-dma-list*))
(let ((v1-0 gp-0))
(set! (-> v1-0 base) (-> v1-0 data))
(set! (-> v1-0 end) (&-> v1-0 data-buffer (-> v1-0 allocated-length)))
)
(add-to-dma-buffer obj gp-0 arg0)
(let* ((v1-3 gp-0)
(a0-1 (the-as dma-packet (-> v1-3 base)))
)
(set! (-> a0-1 dma) (new 'static 'dma-tag :qwc #x2 :id (dma-tag-id cnt)))
(set! (-> a0-1 vif0) (new 'static 'vif-tag))
(set! (-> a0-1 vif1) (new 'static 'vif-tag :imm #x2 :cmd (vif-cmd direct) :msk #x1))
(set! (-> v1-3 base) (the-as pointer (&+ a0-1 16)))
)
(let* ((v1-4 gp-0)
(a0-3 (the-as gs-gif-tag (-> v1-4 base)))
)
(set! (-> a0-3 tag) (new 'static 'gif-tag64 :nloop #x1 :eop #x1 :nreg #x1))
(set! (-> a0-3 regs) GIF_REGS_ALL_AD)
(set! (-> v1-4 base) (the-as pointer (&+ a0-3 16)))
)
(let* ((v1-5 gp-0)
(a0-5 (-> v1-5 base))
)
(set! (-> (the-as (pointer int64) a0-5) 0) 1)
(set! (-> (the-as (pointer gs-reg64) a0-5) 1) (gs-reg64 texflush))
(set! (-> v1-5 base) (&+ a0-5 16))
)
(let* ((v1-6 gp-0)
(a0-7 (the-as object (-> v1-6 base)))
)
(set! (-> (the-as dma-packet a0-7) dma) (new 'static 'dma-tag :id (dma-tag-id end)))
(set! (-> (the-as (pointer int64) a0-7) 1) 0)
(set! (-> v1-6 base) (&+ (the-as pointer a0-7) 16))
)
;; the actual send
(#unless PC_PORT
(dma-buffer-send-chain (the-as dma-bank-source #x1000a000) gp-0)
)
)
;; wait for dma to finish.
(dma-sync (the-as pointer #x1000a000) 0 0)
(none)
)
(defmethod add-to-dma-buffer texture-page ((obj texture-page) (arg0 dma-buffer) (arg1 tex-upload-mode))
"Add upload data for a texture-page. This is a simple version for non common-segment textures."
(local-vars (sv-16 int))
(let ((v1-0 arg1))
(set! sv-16 (cond
((= v1-0 (tex-upload-mode none))
0
)
((= v1-0 (tex-upload-mode seg0-1))
(the-as int (+ (-> obj segment 0 size) (-> obj segment 1 size)))
)
((= v1-0 (tex-upload-mode seg0-1-2))
(the-as int (-> obj size))
)
(else
(the-as int (-> obj segment (the-as int arg1) size))
)
)
)
)
(let* ((v1-7 (max 0 (the-as int arg1)))
(a3-4 (* (/ (+ (/ sv-16 64) 63) 64) 32))
(t1-0 (shr (-> obj segment v1-7 dest) 6))
(a2-10 (-> obj segment v1-7 block-data))
)
(upload-vram-data arg0 (the-as int t1-0) a2-10 a3-4 128)
)
sv-16
)
(defun texture-relocate ((dma-buff dma-buffer) (tex texture) (dest-loc int) (dest-fmt gs-psm) (clut-dst int))
"Move a texture in VRAM. Unrelated to the texture-relocate-later, which moves textures in RAM.
Will try to move the whole thing, including the clut, assuming you provide a destination for it.
Note that this uses the format/width stuff properly, so it will be slower, but won't scramble your texture."
(#when PC_PORT
;; as far as I know this is only used for fonts which have 1 mip level.
(__pc-texture-relocate (/ dest-loc 64) (-> tex dest 0) dest-fmt)
)
(dotimes (v1-0 (the-as int (-> tex num-mips)))
(let ((t1-1 (ash (-> tex w) (- v1-0)))
(t2-3 (ash (-> tex h) (- v1-0)))
)
(let* ((t3-2 dma-buff)
(t4-0 (the-as object (-> t3-2 base)))
)
(set! (-> (the-as dma-packet t4-0) dma) (new 'static 'dma-tag :qwc #x5 :id (dma-tag-id cnt)))
(set! (-> (the-as dma-packet t4-0) vif0) (new 'static 'vif-tag))
(set! (-> (the-as dma-packet t4-0) vif1) (new 'static 'vif-tag :imm #x5 :cmd (vif-cmd direct) :msk #x1))
(set! (-> t3-2 base) (&+ (the-as pointer t4-0) 16))
)
(let* ((t3-3 dma-buff)
(t4-2 (the-as object (-> t3-3 base)))
)
(set! (-> (the-as gs-gif-tag t4-2) tag) (new 'static 'gif-tag64 :nloop #x1 :eop #x1 :nreg #x4))
(set! (-> (the-as gs-gif-tag t4-2) regs) GIF_REGS_ALL_AD)
(set! (-> t3-3 base) (&+ (the-as pointer t4-2) 16))
)
(let* ((t3-4 dma-buff)
(t4-4 (-> t3-4 base))
)
(set! (-> (the-as (pointer gs-bitbltbuf) t4-4) 0) (new 'static 'gs-bitbltbuf
:sbp (-> tex dest v1-0)
:sbw (-> tex width v1-0)
:spsm (the-as int (-> tex psm))
:dbp (/ dest-loc 64)
:dbw (-> tex width v1-0)
:dpsm (the-as int dest-fmt)
)
)
(set! (-> (the-as (pointer gs-reg64) t4-4) 1) (gs-reg64 bitbltbuf))
(set! (-> (the-as (pointer gs-trxpos) t4-4) 2) (new 'static 'gs-trxpos))
(set! (-> (the-as (pointer gs-reg64) t4-4) 3) (gs-reg64 trxpos))
(set! (-> (the-as (pointer gs-trxreg) t4-4) 4) (new 'static 'gs-trxreg :rrw t1-1 :rrh t2-3))
(set! (-> (the-as (pointer gs-reg64) t4-4) 5) (gs-reg64 trxreg))
(set! (-> (the-as (pointer gs-trxdir) t4-4) 6) (new 'static 'gs-trxdir :xdir #x2))
(set! (-> (the-as (pointer gs-reg64) t4-4) 7) (gs-reg64 trxdir))
(set! (-> t3-4 base) (&+ t4-4 64))
)
)
(set! (-> tex dest v1-0) (the-as uint (/ dest-loc 64)))
)
(cond
((< clut-dst 0)
)
((= (-> tex psm) (gs-psm mt4))
(let* ((v1-7 dma-buff)
(a2-2 (the-as object (-> v1-7 base)))
)
(set! (-> (the-as dma-packet a2-2) dma) (new 'static 'dma-tag :qwc #x5 :id (dma-tag-id cnt)))
(set! (-> (the-as dma-packet a2-2) vif0) (new 'static 'vif-tag))
(set! (-> (the-as dma-packet a2-2) vif1) (new 'static 'vif-tag :imm #x5 :cmd (vif-cmd direct) :msk #x1))
(set! (-> v1-7 base) (&+ (the-as pointer a2-2) 16))
)
(let* ((v1-8 dma-buff)
(a2-4 (the-as object (-> v1-8 base)))
)
(set! (-> (the-as gs-gif-tag a2-4) tag) (new 'static 'gif-tag64 :nloop #x1 :eop #x1 :nreg #x4))
(set! (-> (the-as gs-gif-tag a2-4) regs) GIF_REGS_ALL_AD)
(set! (-> v1-8 base) (&+ (the-as pointer a2-4) 16))
)
(let* ((v1-9 dma-buff)
(a2-6 (-> v1-9 base))
)
(set! (-> (the-as (pointer gs-bitbltbuf) a2-6) 0) (new 'static 'gs-bitbltbuf
:sbw #x1
:dbw #x1
:dpsm (-> tex clutpsm)
:dbp (/ clut-dst 64)
:spsm (-> tex clutpsm)
:sbp (-> tex clutdest)
)
)
(set! (-> (the-as (pointer gs-reg64) a2-6) 1) (gs-reg64 bitbltbuf))
(set! (-> (the-as (pointer gs-trxpos) a2-6) 2) (new 'static 'gs-trxpos))
(set! (-> (the-as (pointer gs-reg64) a2-6) 3) (gs-reg64 trxpos))
(set! (-> (the-as (pointer gs-trxreg) a2-6) 4) (new 'static 'gs-trxreg :rrw #x8 :rrh #x2))
(set! (-> (the-as (pointer gs-reg64) a2-6) 5) (gs-reg64 trxreg))
(set! (-> (the-as (pointer gs-trxdir) a2-6) 6) (new 'static 'gs-trxdir :xdir #x2))
(set! (-> (the-as (pointer gs-reg64) a2-6) 7) (gs-reg64 trxdir))
(set! (-> v1-9 base) (&+ a2-6 64))
)
(set! (-> tex clutdest) (the-as uint (/ clut-dst 64)))
)
((= (-> tex psm) (gs-psm mt8))
(let* ((v1-13 dma-buff)
(a2-9 (the-as object (-> v1-13 base)))
)
(set! (-> (the-as dma-packet a2-9) dma) (new 'static 'dma-tag :qwc #x5 :id (dma-tag-id cnt)))
(set! (-> (the-as dma-packet a2-9) vif0) (new 'static 'vif-tag))
(set! (-> (the-as dma-packet a2-9) vif1) (new 'static 'vif-tag :imm #x5 :cmd (vif-cmd direct) :msk #x1))
(set! (-> v1-13 base) (&+ (the-as pointer a2-9) 16))
)
(let* ((v1-14 dma-buff)
(a2-11 (the-as object (-> v1-14 base)))
)
(set! (-> (the-as gs-gif-tag a2-11) tag) (new 'static 'gif-tag64 :nloop #x1 :eop #x1 :nreg #x4))
(set! (-> (the-as gs-gif-tag a2-11) regs) GIF_REGS_ALL_AD)
(set! (-> v1-14 base) (&+ (the-as pointer a2-11) 16))
)
(let* ((v1-15 dma-buff)
(a2-13 (-> v1-15 base))
)
(set! (-> (the-as (pointer gs-bitbltbuf) a2-13) 0) (new 'static 'gs-bitbltbuf
:sbw #x2
:dbw #x2
:dpsm (-> tex clutpsm)
:dbp (/ clut-dst 64)
:spsm (-> tex clutpsm)
:sbp (-> tex clutdest)
)
)
(set! (-> (the-as (pointer gs-reg64) a2-13) 1) (gs-reg64 bitbltbuf))
(set! (-> (the-as (pointer gs-trxpos) a2-13) 2) (new 'static 'gs-trxpos))
(set! (-> (the-as (pointer gs-reg64) a2-13) 3) (gs-reg64 trxpos))
(set! (-> (the-as (pointer gs-trxreg) a2-13) 4) (new 'static 'gs-trxreg :rrw #x10 :rrh #x10))
(set! (-> (the-as (pointer gs-reg64) a2-13) 5) (gs-reg64 trxreg))
(set! (-> (the-as (pointer gs-trxdir) a2-13) 6) (new 'static 'gs-trxdir :xdir #x2))
(set! (-> (the-as (pointer gs-reg64) a2-13) 7) (gs-reg64 trxdir))
(set! (-> v1-15 base) (&+ a2-13 64))
)
(set! (-> tex clutdest) (the-as uint (/ clut-dst 64)))
)
)
(set! (-> tex psm) dest-fmt)
dma-buff
)
(defmethod setup-font-texture texture-pool ((obj texture-pool))
"Do relocations of font textures."
(local-vars (sv-16 int) (sv-20 int))
(let ((s3-0 (-> obj font-palette)))
(set! sv-16 (-> obj cur))
(set! sv-20 (/ s3-0 64))
(let ((s5-0
(texture-page-login (new 'static 'texture-id :index #x1 :page #xc04) texture-page-default-allocate global)
)
)
(if (and s5-0 (-> s5-0 page))
(set! sv-16 (the-as int (-> s5-0 page segment 0 dest)))
)
(let ((s4-0 *txt-dma-list*))
(let ((v1-6 s4-0))
(set! (-> v1-6 base) (-> v1-6 data))
(set! (-> v1-6 end) (&-> v1-6 data-buffer (-> v1-6 allocated-length)))
)
(let ((s2-0 (lookup-texture-by-id (new 'static 'texture-id :index #x1 :page #xc04)))
(s1-0 #xc2000)
(s0-0 36)
)
(set! (-> s2-0 h) 320)
(texture-relocate s4-0 s2-0 s1-0 (the-as gs-psm s0-0) s3-0)
(font-set-tex0 (the-as (pointer gs-tex0) (-> *font-work* small-font-0-tmpl)) s2-0 s1-0 s0-0 sv-20)
(font-set-tex0 (the-as (pointer gs-tex0) (-> *font-work* small-font-2-tmpl)) s2-0 s1-0 s0-0 sv-20)
)
(let ((s3-1 (lookup-texture-by-id (new 'static 'texture-id :page #xc04)))
(s2-1 #xc2000)
(s1-1 44)
)
(set! (-> s3-1 h) 320)
(texture-relocate s4-0 s3-1 s2-1 (the-as gs-psm s1-1) -1)
(font-set-tex0 (the-as (pointer gs-tex0) (-> *font-work* small-font-1-tmpl)) s3-1 s2-1 s1-1 sv-20)
(font-set-tex0 (the-as (pointer gs-tex0) (-> *font-work* small-font-3-tmpl)) s3-1 s2-1 s1-1 sv-20)
)
(let ((s3-2 (lookup-texture-by-id (new 'static 'texture-id :index #x4 :page #xc04)))
(s2-2 #x90000)
(s1-2 36)
)
(set! (-> s3-2 h) 800)
(texture-relocate s4-0 s3-2 s2-2 (the-as gs-psm s1-2) -1)
(font-set-tex0 (the-as (pointer gs-tex0) (-> *font-work* large-font-0-tmpl)) s3-2 s2-2 s1-2 sv-20)
)
(let ((s3-3 (lookup-texture-by-id (new 'static 'texture-id :index #x2 :page #xc04)))
(s2-3 #x90000)
(s1-3 44)
)
(set! (-> s3-3 h) 800)
(texture-relocate s4-0 s3-3 s2-3 (the-as gs-psm s1-3) -1)
(font-set-tex0 (the-as (pointer gs-tex0) (-> *font-work* large-font-1-tmpl)) s3-3 s2-3 s1-3 sv-20)
)
(let ((s3-4 (lookup-texture-by-id (new 'static 'texture-id :index #x5 :page #xc04)))
(s2-4 #x5e000)
(s1-4 36)
)
(set! (-> s3-4 h) 800)
(texture-relocate s4-0 s3-4 s2-4 (the-as gs-psm s1-4) -1)
(font-set-tex0 (the-as (pointer gs-tex0) (-> *font-work* large-font-2-tmpl)) s3-4 s2-4 s1-4 sv-20)
)
(let ((s3-5 (lookup-texture-by-id (new 'static 'texture-id :index #x3 :page #xc04)))
(s2-5 #x5e000)
(s1-5 44)
)
(set! (-> s3-5 h) 800)
(texture-relocate s4-0 s3-5 s2-5 (the-as gs-psm s1-5) -1)
(font-set-tex0 (the-as (pointer gs-tex0) (-> *font-work* large-font-3-tmpl)) s3-5 s2-5 s1-5 sv-20)
)
(let* ((v1-28 s4-0)
(a0-26 (the-as dma-packet (-> v1-28 base)))
)
(set! (-> a0-26 dma) (new 'static 'dma-tag :qwc #x2 :id (dma-tag-id cnt)))
(set! (-> a0-26 vif0) (new 'static 'vif-tag))
(set! (-> a0-26 vif1) (new 'static 'vif-tag :imm #x2 :cmd (vif-cmd direct) :msk #x1))
(set! (-> v1-28 base) (the-as pointer (&+ a0-26 16)))
)
(let* ((v1-29 s4-0)
(a0-28 (the-as gs-gif-tag (-> v1-29 base)))
)
(set! (-> a0-28 tag) (new 'static 'gif-tag64 :nloop #x1 :eop #x1 :nreg #x1))
(set! (-> a0-28 regs) GIF_REGS_ALL_AD)
(set! (-> v1-29 base) (the-as pointer (&+ a0-28 16)))
)
(let* ((v1-30 s4-0)
(a0-30 (-> v1-30 base))
)
(set! (-> (the-as (pointer int64) a0-30) 0) 1)
(set! (-> (the-as (pointer gs-reg64) a0-30) 1) (gs-reg64 texflush))
(set! (-> v1-30 base) (&+ a0-30 16))
)
(let* ((v1-31 s4-0)
(a0-32 (the-as object (-> v1-31 base)))
)
(set! (-> (the-as dma-packet a0-32) dma) (new 'static 'dma-tag :id (dma-tag-id end)))
(set! (-> (the-as (pointer int64) a0-32) 1) 0)
(set! (-> v1-31 base) (&+ (the-as pointer a0-32) 16))
)
(#unless PC_PORT
(dma-buffer-send-chain (the-as dma-bank-source #x10009000) s4-0)
)
)
(dma-sync (the-as pointer #x10009000) 0 0)
(if (and s5-0 (-> s5-0 page) (= (-> obj cur) (+ sv-16 (-> s5-0 page size))))
(set! (-> obj cur) sv-16)
(format 0 "ERROR: could not resize texture pool to remove gamefont.~%")
)
)
)
0
(none)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; basic methods for texture-page-dir
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; the texture-page-dir contains an entry per texture page, for every texture page that we will ever see.
;; at runtime, the level system will allocate link arrays per page. Each page has an array of "link"s, with
;; one link per texture. The link is the head of a linked list through all the static adgif-shaders of the
;; level.
(defmethod asize-of texture-page-dir ((obj texture-page-dir))
"Get the size in memory of a texture-page-dir, just the main array, not allocated link stuff."
(the-as int (+ (-> texture-page-dir size) (* 12 (+ (-> obj length) -1))))
)
(defmethod length texture-page-dir ((obj texture-page-dir))
"Get the number of elements."
(-> obj length)
)
(defmethod relocate texture-page-dir ((obj texture-page-dir) (arg0 kheap) (arg1 (pointer uint8)))
"Set up a texture-page-dir when it is loaded."
;; there's just one of these, just set the global one to this.
(set! *texture-page-dir* obj)
(none)
)
(defmethod relocate-dests! texture-page ((obj texture-page) (new-dest int) (segs int))
"Update a texture-page so the texture-page and all its textures point to a new vram
address."
(let ((new-tbp (shr new-dest 6))
(old-tbp (shr (-> obj segment segs dest) 6))
)
(when (!= new-tbp old-tbp)
(dotimes (tex-idx (-> obj length))
(when (-> obj data tex-idx)
(let* ((tex (-> obj data tex-idx))
(num-mips (-> tex num-mips))
)
(if (zero? segs)
(set! (-> tex clutdest) (+ (- (-> tex clutdest) old-tbp) new-tbp))
)
(dotimes (mip-idx (the-as int num-mips))
(let ((t4-0 mip-idx)
(t5-0 num-mips)
)
(if (= segs (if (>= (the-as uint 2) t5-0)
(+ (- -1 t4-0) t5-0)
(max 0 (- 2 t4-0))
)
)
(set! (-> tex dest mip-idx) (+ (- (-> tex dest mip-idx) old-tbp) new-tbp))
)
)
)
)
)
)
(set! (-> obj segment segs dest) (the-as uint new-dest))
)
)
(none)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; texture-page management
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmethod relocate texture-page ((obj texture-page) (loading-heap kheap) (name (pointer uint8)))
"Set up a texture-page when it is loaded. This function is called by the linker when
loading is completed."
(cond
;; version check!
((or (not obj) (not (file-info-correct-version? (-> obj info) (file-kind tpage) 0)))
(the-as texture-page #f)
)
(else
(let ((loading-level (-> *level* loading-level)))
(when loading-level
;; if we have a currently loading-level, put this in the loaded-texture-page list
(set! (-> loading-level loaded-texture-page (-> loading-level loaded-texture-page-count)) obj)
(+! (-> loading-level loaded-texture-page-count) 1)
;; move from small-edge to small-center mode if we have 2 or more tpages, I guess?
(if (and (>= (-> loading-level loaded-texture-page-count) 2) (zero? (-> loading-level load-buffer-mode)))
(set! (-> loading-level load-buffer-mode) (load-buffer-mode small-center))
)
)
)
;; set up dests (no idea why the tpage doesn't come with this set properly)
(set! (-> obj segment 1 dest) (-> obj segment 0 size))
(set! (-> obj segment 2 dest) (+ (-> obj segment 0 size) (-> obj segment 1 size)))
;; PC port: added texture remap
(dotimes (texture-idx (-> obj length))
(let ((tex (-> obj data texture-idx)))
(when (and tex (nonzero? tex))
(let ((offset (__pc-get-tex-remap (the int (-> obj id)) texture-idx)))
(when (nonzero? offset)
)
(+! (-> tex dest 0) offset)
)
)
)
)
(let* ((tpage-id (-> obj id))
(dir-entry (-> *texture-page-dir* entries tpage-id))
)
;; clear the memcpy later flag, the allocation function will set it if needed
;; (I think this never happens in jak 2?)
(set! (-> *texture-relocate-later* memcpy) #f)
;; do allocation!
((-> *texture-pool* allocate-func) *texture-pool* obj loading-heap (the-as int tpage-id))
(cond
((not (-> *texture-relocate-later* memcpy))
;; not postponing texture memcpy, so it's safe to allocate links now.
;; (otherwise its unsafe because we'll want to kick out the texture)
(set! (-> dir-entry page) obj)
(if (not (-> dir-entry link))
(set! (-> dir-entry link)
(the-as texture-link (malloc 'loading-level (* (max (-> dir-entry length) (-> obj length)) 4)))
)
)
)
(else
;; postponing memcpy and link allocation, fill out our info.
(let ((v1-19 *texture-relocate-later*))
(set! (-> v1-19 entry) dir-entry)
(set! (-> v1-19 page) obj)
)
)
)
)
obj
)
)
)
(defun relocate-later ()
"The other half to texture-relocate-later: this function does the pending memcpy."
(let ((gp-0 *texture-relocate-later*))
(let ((s5-0 (-> gp-0 entry))
(s4-0 (-> gp-0 page))
)
(ultimate-memcpy (the-as pointer (-> gp-0 dest)) (the-as pointer (-> gp-0 source)) (-> gp-0 move))
(set! (-> s5-0 page) s4-0)
(if (not (-> s5-0 link))
(set! (-> s5-0 link)
(the-as texture-link (malloc 'loading-level (* (max (-> s5-0 length) (-> s4-0 length)) 4)))
)
)
)
(set! (-> gp-0 memcpy) #f)
)
#f
)
(defun texture-page-login ((tex-id texture-id) (alloc-func (function texture-pool texture-page kheap int texture-page)) (heap kheap))
"Get a texture-page-dir-entry for the given texture.
If the texture page is not loaded, it will attempt to load it with loado, which
would only succeed on development machines."
;; make sure it's a valid tpage id
(when (and (nonzero? (-> tex-id page)) (< (-> tex-id page) (the-as uint (-> *texture-page-dir* length))))
;; check the existing entry
(let ((dir-entry (-> *texture-page-dir* entries (-> tex-id page))))
(when (not (-> dir-entry page)) ;; empty entry, need to load!
;; don't forget the old allocation function...
(let ((old-alloc-func (-> *texture-pool* allocate-func)))
(set! (-> *texture-pool* allocate-func) alloc-func)
;; load and call relocate.
(let* ((name (make-file-name (file-kind tpage) (the-as string (* (-> tex-id page) 8)) 0 #f))
(loaded-tpage (the-as texture-page (loado name heap)))
)
(if loaded-tpage
(relocate loaded-tpage heap (charp-basename (-> name data)))
)
)
(set! (-> *texture-pool* allocate-func) old-alloc-func)
)
)
dir-entry
)
)
)
(defun lookup-texture-by-id ((arg0 texture-id))
"Get a texture for the given texture-id.
This will do a load that only succeeds on development hardware if it doesn't exist."
(let ((a0-2 (texture-page-login arg0 texture-page-default-allocate loading-level))
(v1-0 (the-as texture-page #f))
)
(if (and a0-2 (begin (set! v1-0 (-> a0-2 page)) v1-0) (< (-> arg0 index) (the-as uint (-> v1-0 length))))
(-> v1-0 data (-> arg0 index))
)
)
)
(defun lookup-texture-by-id-fast ((arg0 texture-id))
"Get a texture for the given id. return #f if it doesn't exist."
(let ((a1-2 (if (and (nonzero? (-> arg0 page)) (< (-> arg0 page) (the-as uint (-> *texture-page-dir* length))))
(-> *texture-page-dir* entries (-> arg0 page))
)
)
(v1-6 (the-as texture-page #f))
)
(if (and a1-2 (begin (set! v1-6 (-> a1-2 page)) v1-6) (< (-> arg0 index) (the-as uint (-> v1-6 length))))
(-> v1-6 data (-> arg0 index))
)
)
)
(defun lookup-texture-by-name ((arg0 string) (arg1 string) (arg2 (pointer texture-page)))
"Get texture by name. Slow. Return #f if it doesn't exist."
(local-vars (sv-16 texture-page-dir))
(set! sv-16 *texture-page-dir*)
(dotimes (s3-0 (-> sv-16 length))
(let ((s2-0 (-> sv-16 entries s3-0 page)))
(when (and s2-0 (or (not arg1) (string= (-> s2-0 name) arg1)))
(dotimes (s1-0 (-> s2-0 length))
(let ((s0-0 (-> s2-0 data s1-0)))
(when (and s0-0 (string= (-> s0-0 name) arg0))
(if arg2
(set! (-> arg2 0) s2-0)
)
(return s0-0)
)
)
)
)
)
)
(the-as texture #f)
)
(defun lookup-texture-id-by-name ((arg0 string) (arg1 string))
"Get texture id by name. Slow. Return 0 if it doesn't exist."
(local-vars (sv-16 texture-page-dir))
(set! sv-16 *texture-page-dir*)
(dotimes (gp-0 (-> sv-16 length))
(let ((s3-0 (-> sv-16 entries gp-0 page)))
(when (and s3-0 (or (not arg1) (string= (-> s3-0 name) arg1)))
(dotimes (s2-0 (-> s3-0 length))
(let ((v1-7 (-> s3-0 data s2-0)))
(if (and v1-7 (string= (-> v1-7 name) arg0))
(return (new 'static 'texture-id :page gp-0 :index s2-0))
)
)
)
)
)
)
(the-as texture-id 0)
)
(defun lookup-level-texture-by-name ((arg0 string) (arg1 level) (arg2 (pointer texture-page)))
"Like lookup-texture-by-name, but will check texture-pages listed in this level first.
Unclear why these wouldn't be part of the texture-page-dir."
(dotimes (s3-0 18)
(let ((s2-0 (-> arg1 texture-page s3-0)))
(when (and s2-0 (nonzero? s2-0))
(dotimes (s1-0 (-> s2-0 length))
(let ((s0-0 (-> s2-0 data s1-0)))
(when (and s0-0 (string= (-> s0-0 name) arg0))
(if arg2
(set! (-> arg2 0) s2-0)
)
(return s0-0)
)
)
)
)
)
)
(lookup-texture-by-name arg0 (the-as string #f) arg2)
)
(defmethod unload-page texture-pool ((obj texture-pool) (arg0 texture-page))
"Unload the given texture-page from the texture-page-dir."
(local-vars (a0-2 int))
(let ((v1-0 *texture-page-dir*))
(dotimes (a0-1 (-> v1-0 length))
(when (= arg0 (-> v1-0 entries a0-1 page))
(set! a0-2 a0-1)
(goto cfg-7)
)
)
(set! a0-2 -1)
(label cfg-7)
(when (>= a0-2 0)
(set! (-> v1-0 entries a0-2 page) #f)
(set! (-> v1-0 entries a0-2 link) #f)
)
)
0
(none)
)
;;;;;;;;;;;;;;;;;;;;;;;;;
;; adgif shader/link
;;;;;;;;;;;;;;;;;;;;;;;;;
;; debug menu shader editor
(define *shader-list* '())
(define *edit-shader* (new 'static 'texture-id))
(defun link-texture-by-id ((arg0 texture-id) (arg1 adgif-shader))
"Link the adgif-shader to the texture specified."
(when (not (or (zero? (-> arg0 page)) (>= (-> arg0 page) (the-as uint (-> *texture-page-dir* length)))))
(let ((s4-0 (-> *texture-page-dir* entries (-> arg0 page))))
(if (not (-> s4-0 link))
(set! (-> s4-0 link) (the-as texture-link (malloc 'loading-level (* (-> s4-0 length) 4))))
)
(when (< (-> arg0 index) (the-as uint (-> s4-0 length)))
(set! (-> arg1 next shader) (-> s4-0 link next (-> arg0 index) shader))
(set! (-> s4-0 link next (-> arg0 index) shader) (shr (the-as int arg1) 4))
)
s4-0
)
)
)
(defmethod unlink-shaders-in-heap texture-page-dir ((obj texture-page-dir) (heap kheap))
"Unlink all adgif shaders that are in heap.
This iterates through _everything_ so it is somewhat slow."
(local-vars (dist-past-end uint))
(let ((mem-start (-> heap base))
(mem-end (-> heap top-base))
)
(dotimes (entry-idx (-> obj length))
(let* ((entry (-> obj entries entry-idx))
(tex-page (-> entry page))
)
(when tex-page
(let ((link-arr (-> entry link next))
(tex-count (min (-> tex-page length) (-> entry length)))
)
0
(when link-arr
(dotimes (tex-idx tex-count)
(let ((link-slot (&-> link-arr 0))
(shader (the-as adgif-shader (* (-> link-arr 0 shader) 16)))
)
(while (nonzero? (the-as uint shader))
(b!
(< (the-as int (- (the-as uint shader) (the-as uint mem-start))) 0)
cfg-8
:delay (set! dist-past-end (- (the-as uint shader) (the-as uint mem-end)))
)
(b! (>= (the-as int dist-past-end) 0) cfg-8 :delay (nop!))
(let ((t4-2 (-> shader next)))
(b! #t cfg-9 :delay (set! (-> link-slot 0) t4-2))
)
(label cfg-8)
(set! link-slot (&-> shader next))
(label cfg-9)
(set! shader (the-as adgif-shader (* (-> shader next shader) 16)))
)
)
(set! link-arr (&-> link-arr 1))
)
)
)
)
)
)
)
0
)
(defun adgif-shader<-texture! ((arg0 adgif-shader) (arg1 texture))
"Set up an adgif-shader from a texture."
(set! (-> arg0 tex1 mxl) (+ (-> arg1 num-mips) -1))
(set! (-> arg0 tex1 l) (-> arg1 mip-shift))
(set! (-> arg0 tex1 mmag) (logand (-> arg1 tex1-control) 1))
(set! (-> arg0 tex1 mmin) (shr (-> arg1 tex1-control) 1))
(set! (-> arg0 tex0) (new 'static 'gs-tex0
:tcc #x1
:cld #x1
:cpsm (-> arg1 clutpsm)
:cbp (-> arg1 clutdest)
:tfx (-> arg0 tex0 tfx)
:th (log2 (-> arg1 h))
:tw (log2 (-> arg1 w))
:tbw (-> arg1 width 0)
:tbp0 (-> arg1 dest 0)
:psm (the-as int (-> arg1 psm))
)
)
(set! (-> arg0 miptbp1) (new 'static 'gs-miptbp
:tbp1 (-> arg1 dest 1)
:tbw1 (-> arg1 width 1)
:tbp2 (-> arg1 dest 2)
:tbw2 (-> arg1 width 2)
:tbp3 (-> arg1 dest 3)
:tbw3 (-> arg1 width 3)
)
)
(when (< (the-as uint 4) (-> arg1 num-mips))
(set! (-> arg0 alpha-as-miptb2) (new 'static 'gs-miptbp
:tbp1 (-> arg1 dest 4)
:tbw1 (-> arg1 width 4)
:tbp2 (-> arg1 dest 5)
:tbw2 (-> arg1 width 5)
:tbp3 (-> arg1 dest 6)
:tbw3 (-> arg1 width 6)
)
)
(set! (-> (&-> arg0 reg-4-u32) 0) (gs-reg32 miptbp2-1))
)
arg0
)
(defun adgif-shader-update! ((arg0 adgif-shader) (arg1 texture))
"Update an adgif shader in response to a texture uv-dist change."
(let ((s5-0 (the int (/ 256.0 (-> arg1 uv-dist)))))
(case (-> arg0 tex1 l)
((1)
(set! (-> arg0 tex1 k) (+ (logand (ash s5-0 (- 5 (log2 s5-0))) 31) -350 (* (log2 s5-0) 32)))
)
(else
(set! (-> arg0 tex1 k) (+ (logand (ash s5-0 (- 4 (log2 s5-0))) 15) -175 (* (log2 s5-0) 16)))
)
)
)
(none)
)
;; combines the previous two functions.
(def-mips2c adgif-shader<-texture-with-update! (function adgif-shader texture adgif-shader))
(defun hack-texture ((arg0 texture))
"Some sort of uv hack for hi-res mode"
(set! (-> arg0 uv-dist) 1000000.0)
(set! (-> arg0 masks data 0 dist) (+ 40960000.0 (-> arg0 masks data 0 dist)))
(set! (-> arg0 masks data 1 dist) (+ 40960000.0 (-> arg0 masks data 1 dist)))
)
(define-extern level-remap-texture (function texture-id texture-id))
(defun adgif-shader-login ((arg0 adgif-shader))
"Initialize an adgif-shader
confirm the texture exists, and add to texture system.
Use the level system to remap the texture-id in the adgif-shader.
If the texture doesn't exist, will load it with loado."
;; only if we haven't done it before
(when (logtest? (-> arg0 link-test) (link-test-flags needs-log-in))
(logclear! (-> arg0 link-test) (link-test-flags needs-log-in bit-9))
(set! (-> arg0 texture-id) (level-remap-texture (-> arg0 texture-id)))
(when (= (-> arg0 texture-id page) 2797)
(nop!)
(nop!)
0
)
;; add us to list of adgifs for this texture
(link-texture-by-id (-> arg0 texture-id) arg0)
;; find the texture
(let ((s5-0 (lookup-texture-by-id (-> arg0 texture-id))))
(cond
(s5-0
;; hack! set some stuff differently if we're screenshotting
(if (and *debug-segment* (-> *screen-shot-work* highres-enable))
(hack-texture s5-0)
)
;; set up this adgif shader from the texture.
(adgif-shader<-texture-with-update! arg0 s5-0)
)
(else
(format 0 "login<1> could not find texture ~X in obj ~A shader ~X~%"
(-> arg0 texture-id)
(-> *kernel-context* login-object)
arg0
)
)
)
s5-0
)
)
)
(defun adgif-shader-login-no-remap ((arg0 adgif-shader))
"Initialize an adgif-shader like adgif-shader-login, but skips
the level-remap-texture system."
(when (logtest? (-> arg0 link-test) (link-test-flags needs-log-in))
(logclear! (-> arg0 link-test) (link-test-flags needs-log-in bit-9))
(link-texture-by-id (-> arg0 texture-id) arg0)
(let ((s5-0 (lookup-texture-by-id (-> arg0 texture-id))))
(cond
(s5-0
(if (and *debug-segment* (-> *screen-shot-work* highres-enable))
(hack-texture s5-0)
)
(adgif-shader<-texture-with-update! arg0 s5-0)
)
(else
(format 0 "login<2> could not find texture ~X in obj ~A shader ~X~%"
(-> arg0 texture-id)
(-> *kernel-context* login-object)
arg0
)
)
)
s5-0
)
)
)
(defun adgif-shader-login-fast ((arg0 adgif-shader))
"Initialize an adgif-shader and register with texture system, but doesn't handle missing textures.
Will remap with level info."
(when (logtest? (-> arg0 link-test) (link-test-flags needs-log-in))
(logclear! (-> arg0 link-test) (link-test-flags needs-log-in bit-9))
(set! (-> arg0 texture-id) (level-remap-texture (-> arg0 texture-id)))
(let ((v1-4 (-> arg0 texture-id)))
(when (and (nonzero? (-> v1-4 page)) (< (-> v1-4 page) (the-as uint (-> *texture-page-dir* length))))
(let ((a0-9 (-> *texture-page-dir* entries (-> v1-4 page))))
(when (and (< (-> v1-4 index) (the-as uint (-> a0-9 length))) (-> a0-9 link))
(set! (-> arg0 next shader) (-> a0-9 link next (-> v1-4 index) shader))
(set! (-> a0-9 link next (-> v1-4 index) shader) (shr (the-as int arg0) 4))
)
(when (and (-> a0-9 page) (< (-> v1-4 index) (the-as uint (-> a0-9 page length))))
(let ((s5-0 (-> a0-9 page data (-> v1-4 index))))
(when s5-0
(if (and *debug-segment* (-> *screen-shot-work* highres-enable))
(hack-texture s5-0)
)
(adgif-shader<-texture-with-update! arg0 s5-0)
)
s5-0
)
)
)
)
)
)
)
(defun adgif-shader-login-no-remap-fast ((arg0 adgif-shader))
"Initialize an adgif-shader and register with texture system, but doesn't handle missing textures.
Does not remap with level info."
(when (logtest? (-> arg0 link-test) (link-test-flags needs-log-in))
(logclear! (-> arg0 link-test) (link-test-flags needs-log-in bit-9))
(let ((v1-4 (-> arg0 texture-id)))
(when (and (nonzero? (-> v1-4 page)) (< (-> v1-4 page) (the-as uint (-> *texture-page-dir* length))))
(let ((a0-8 (-> *texture-page-dir* entries (-> v1-4 page))))
(when (and (< (-> v1-4 index) (the-as uint (-> a0-8 length))) (-> a0-8 link))
(set! (-> arg0 next shader) (-> a0-8 link next (-> v1-4 index) shader))
(set! (-> a0-8 link next (-> v1-4 index) shader) (shr (the-as int arg0) 4))
)
(when (and (-> a0-8 page) (< (-> v1-4 index) (the-as uint (-> a0-8 page length))))
(let ((s5-0 (-> a0-8 page data (-> v1-4 index))))
(when s5-0
(if (and *debug-segment* (-> *screen-shot-work* highres-enable))
(hack-texture s5-0)
)
(adgif-shader<-texture-with-update! arg0 s5-0)
)
s5-0
)
)
)
)
)
)
)
;; when not debugging, use the "fast" ones.
(when (not *debug-segment*)
(set! adgif-shader-login adgif-shader-login-fast)
(set! adgif-shader-login-no-remap adgif-shader-login-no-remap-fast)
)
(defun adgif-shader<-texture-simple! ((arg0 adgif-shader) (arg1 texture))
(set! (-> arg0 tex1) (new 'static 'gs-tex1 :mmag #x1 :mmin #x1))
(set! (-> arg0 tex0 tfx) 0)
(if arg1
(adgif-shader<-texture! arg0 arg1)
)
(set! (-> arg0 clamp) (new 'static 'gs-clamp :wms (gs-tex-wrap-mode clamp) :wmt (gs-tex-wrap-mode clamp)))
(set! (-> arg0 alpha) (new 'static 'gs-alpha :b #x1 :d #x1))
(set! (-> arg0 prims 1) (gs-reg64 tex0-1))
(set! (-> arg0 prims 3) (gs-reg64 tex1-1))
(set! (-> arg0 prims 5) (gs-reg64 miptbp1-1))
(set! (-> arg0 clamp-reg) (gs-reg64 clamp-1))
(set! (-> arg0 prims 9) (gs-reg64 alpha-1))
arg0
)
(defun set-dirty-mask! ((arg0 level) (arg1 int) (arg2 int) (arg3 int))
"Set dirty bits for a levels textures. This tells the texture system to reupload the texture.
even if the old version is still in vram.
Sets bits arg2 -> arg3 for page arg1.
"
(let ((s4-0 (sar (+ arg2 #x3fff) 14))
(s5-0 (sar (+ arg3 #x3fff) 14))
(gp-0 (-> arg0 texture-dirty-masks arg1))
(v1-5 (new 'stack 'texture-mask))
)
(cond
((< 64 s4-0)
(set! (-> v1-5 mask dword 0) (the-as uint -1))
(set! (-> v1-5 mask dword 1) (the-as uint (+ (ash 1 (+ s4-0 -64)) -1)))
)
(else
(set! (-> v1-5 mask dword 0) (the-as uint (+ (ash 1 s4-0) -1)))
)
)
(when (nonzero? s5-0)
(set! (-> v1-5 mask dword 1)
(logior (ash (-> v1-5 mask dword 1) s5-0) (ash (-> v1-5 mask dword 0) (+ s5-0 -64)))
)
(set! (-> v1-5 mask dword 0) (ash (-> v1-5 mask dword 0) s5-0))
)
(set! (-> gp-0 mask dword 0) (the-as uint (logior (-> gp-0 mask dword 0) (-> v1-5 mask dword 0))))
(set! (-> gp-0 mask dword 1) (the-as uint (logior (-> gp-0 mask dword 1) (-> v1-5 mask dword 1))))
)
0
(none)
)
(defun-debug texture-page-dir-inspect ((arg0 texture-page-dir) (arg1 symbol))
(format #t "[~8x] ~A~%" arg0 (-> arg0 type))
(let ((v1-0 *texture-pool*))
(format
#t
"~Ttexture pool (~DK used, ~DK free)~%"
(/ (- (-> v1-0 cur) (-> v1-0 top)) 256)
(/ (- (shl (-> *video-params* display-fbp) 11) (-> v1-0 cur)) 256)
)
)
(dotimes (s4-0 (-> *level* length))
(let ((a1-3 (-> *level* level s4-0)))
(if (= (-> a1-3 status) 'active)
(texture-page-size-check *texture-pool* a1-3 #f)
)
)
)
(format #t "~Tlength: ~D~%" (-> arg0 length))
(format #t "~Tdata[~D]: @ #x~X~%" (-> arg0 length) (-> arg0 entries))
(dotimes (s4-1 (-> arg0 length))
(let ((s3-0 (-> arg0 entries s4-1 page))
(s2-0 (-> arg0 entries s4-1 link))
)
(cond
(s3-0
(format
#t
"~T [~3D] loaded ~S ~A~%"
s4-1
(if s2-0
" linked"
"unlinked"
)
s3-0
)
)
(else
(if (= arg1 'full)
(format
#t
"~T [~3D] unloaded ~S #<texture-page :length ~D>~%"
s4-1
(if s2-0
" linked"
"unlinked"
)
(-> arg0 entries s4-1 length)
)
)
)
)
(when (and (or s3-0 s2-0) arg1)
(dotimes (s1-0 (-> arg0 entries s4-1 length))
(cond
((not s2-0)
(format #t "~T [~3D] unlinked" s1-0)
)
((zero? (-> s2-0 next s1-0 shader))
(format #t "~T [~3D] UNUSED " s1-0)
)
(else
(let ((t9-9 format)
(a0-12 #t)
(a1-10 "~T [~3D] ~3D links ")
(a2-11 s1-0)
(a3-9 0)
)
(let ((v1-40 (the-as object (* (-> s2-0 next s1-0 shader) 16))))
(while (nonzero? (the-as uint v1-40))
(nop!)
(+! a3-9 1)
(set! v1-40 (* (-> (the-as adgif-shader v1-40) next shader) 16))
)
)
(t9-9 a0-12 a1-10 a2-11 a3-9)
)
)
)
(cond
((not s3-0)
(format #t " unloaded~%")
)
((not (-> s3-0 data s1-0))
(format #t " empty~%")
)
(else
(format #t " ~A~%" (-> s3-0 data s1-0))
)
)
)
)
)
)
(none)
)
(defmethod inspect texture-page-dir ((obj texture-page-dir))
(texture-page-dir-inspect obj #f)
obj
)
(define *texture-pool* (new 'global 'texture-pool))
Reference in a new issue View git blame Copy permalink