SpindleyQ/honeylisp
1
1
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

implement draw-object & pei slamming

Browse source 
asm: allow computed addresses, not just immediate mode values
map llissp source to assembly
This commit is contained in:
Jeremy Penner 2021-09-10 22:55:47 -04:00
parent ba03b74278
commit d2ff69258f
8 changed files with 171 additions and 46 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
asm/65816.fnl
View file

@ -50,8 +50,17 @@
(tonumber (addr:sub 2))))
(fn addr-parser [addr] (or (dp-addr addr) (tonumber addr)))
(fn explicit-mode-arg [arg]
(var result nil)
(when (= (type arg) :table)
(each [mode arg (pairs arg)]
(when (= (type mode) :string)
(set result [mode arg]))))
result)
(fn parse-mode-arg [op]
(match op
(where [_ arg] (explicit-mode-arg arg)) (explicit-mode-arg arg)
(where [mvx srcbank dstbank]
(= (type srcbank) :number) (= (type dstbank) :number) (= (mvx:sub 1 2) :mv))
[:bm [dstbank srcbank]] ; encoded backwards for some reason
@ -90,8 +99,10 @@
(fn addr-page [addr] (math.floor (/ addr 0x10000)))
(fn op-pdat.patch [op env]
(local long-mode (match op.mode :abs :abl :abx :alx))
(when (and long-mode (not= (addr-page (env:lookup-org op.arg))
(addr-page env.root-block.org)))
(when (and long-mode
(not= (type op.arg) :function)
(not= (addr-page (env:lookup-org op.arg))
(addr-page env.root-block.org)))
(set op.mode long-mode)))
(fn op-pdat.size [op env]
@ -110,19 +121,18 @@
(local bytegen (. opcodes op.opcode))
(if bytegen
(let [opbyte (bytegen op.mode)
arg (if (= (type op.arg) :function) (op.arg env) op.arg)
argbytes
(if
(or (= op.mode :sr) (= op.mode :isy)) (int8-to-bytes op.arg)
(= op.mode :bm) (.. (int8-to-bytes (. op.arg 1)) (int8-to-bytes (. op.arg 2)))
(and (= op.mode :imm) (= (type op.arg) "function"))
(int16-to-bytes (op.arg env))
(and (= op.mode :imm) (= (op-pdat.size op env) 3)) (int16-to-bytes op.arg)
(and (= op.mode :imm) (= (op-pdat.size op env) 2)) (int8-to-bytes op.arg)
(= op.mode :rel) (int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2)))
(= op.mode :rell) (int16-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 3)))
(= (op-pdat.size op env) 2) (int8-to-bytes (env:lookup-addr op.arg))
(= (op-pdat.size op env) 3) (int16-to-bytes (env:lookup-addr op.arg))
(= (op-pdat.size op env) 4) (int24-to-bytes (env:lookup-addr op.arg))
(or (= op.mode :sr) (= op.mode :isy)) (int8-to-bytes arg)
(= op.mode :bm) (.. (int8-to-bytes (. arg 1)) (int8-to-bytes (. arg 2)))
(and (= op.mode :imm) (= (op-pdat.size op env) 3)) (int16-to-bytes arg)
(and (= op.mode :imm) (= (op-pdat.size op env) 2)) (int8-to-bytes arg)
(= op.mode :rel) (int8-to-bytes (- (env:lookup-addr arg) (+ op.addr 2)))
(= op.mode :rell) (int16-to-bytes (- (env:lookup-addr arg) (+ op.addr 3)))
(= (op-pdat.size op env) 2) (int8-to-bytes (env:lookup-addr arg))
(= (op-pdat.size op env) 3) (int16-to-bytes (env:lookup-addr arg))
(= (op-pdat.size op env) 4) (int24-to-bytes (env:lookup-addr arg))
"")]
(if opbyte
(.. (int8-to-bytes opbyte) argbytes)

9
asm/asm.fnl
View file

@ -49,11 +49,14 @@
(let [opcode (. dat 1)
parser (. dat-parser opcode)
meta (getmetatable dat)
pdat
(if parser (parser dat block)
(. opcodes opcode) (dat-parser.op dat)
(error (.. "Unrecognized opcode " (fv opcode))))]
(when pdat
(when meta (set block.last-meta meta))
(set pdat.meta block.last-meta)
(set pdat.nearest-symbol block.last-symbol)
(table.insert block.pdats pdat)
(when pdat.globals
@ -106,10 +109,14 @@
:pad {}
})
(fn describe-pdat [pdat]
(if pdat.meta (.. pdat.meta.filename "@" pdat.meta.line)
(.. (or pdat.nearest-symbol "<start of block>") " @" (or pdat.addr "<no address>"))))
(fn process-pdat [pdat process default ...]
(fn complain [ok ...]
(if ok (values ...)
(do (error (.. process " failed in " pdat.type " near " (or pdat.nearest-symbol "<start of block>") " @" (or pdat.addr "<no address>") " - " ...)))))
(do (error (.. process " failed in " pdat.type " near " (describe-pdat pdat) " - " ...)))))
(local processor (. pdat-processor pdat.type process))
(if processor (complain (pcall #(processor pdat $...) ...)) default))

9
lib/util.fnl
View file

@ -120,12 +120,13 @@
(fn [_ iprev] (let [i (if iprev (+ iprev 2) 1)]
(when (< i (length l)) (values i (. l i) (. l (+ i 1)))))))
(fn countiter [minmax ?max]
(fn countiter [minmax ?max ?step]
(let [min (if ?max minmax 1)
max (or ?max minmax)]
max (or ?max minmax)
step (or ?step 1)]
(fn [_ iprev]
(let [i (if iprev (+ iprev 1) min)]
(when (<= i max) i)))))
(let [i (if iprev (+ iprev step) min)]
(when (if (> step 0) (<= i max) (>= i max)) i)))))
{: int8-to-bytes : int16-to-bytes : int24-to-bytes : int32-to-bytes : bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24
: splice : lo : hi : loword : hiword

55
neutgs/init.fnl
View file

@ -7,6 +7,7 @@
(compile ssc
(require ssc.iigs.bootstub)
(require ssc.iigs.toolbox)
(require ssc.iigs.graphics)
(tooltable toolsets
ToolsetIntegerMath 0x0100
@ -50,12 +51,27 @@
(asm
(lda 16) (sta [ssc.LONG_LO]) (clc)
(lda tile) (tax) (lda addr) (tay)
(phb)
(bra draw)
loop
(tya) (adc 152) (tay)
draw
(lda 7) (mvn 0 0xe1)
(dec [ssc.LONG_LO]) (bne loop)))
(lda 7) (mvn 6 1)
(dec [ssc.LONG_LO]) (bne loop)
(plb)))
(fn shadow-rewrite-tile (addr)
(asm
(lda 16) (sta [ssc.LONG_LO]) (clc)
(lda addr) (tay) (tax)
(phb)
(bra draw)
loop
(tya) (adc 152) (tay) (tax)
draw
(lda 7) (mvn 1 1)
(dec [ssc.LONG_LO]) (bne loop)
(plb)))
(global word userID)
@ -65,9 +81,17 @@
(yield)
(set! i (+ i 1)))))
(form itile-to-tile [(fn [ssc itile] [:block (ssc:expr-word itile) [:asl] [:asl] [:asl] [:asl] [:asl] [:asl] [:asl] [:clc] [:adc #($1:lookup-addr :tiles)]])])
(form itile-to-tile [(fn [ssc itile]
[:block (ssc:expr-word itile) [:asl] [:asl] [:asl] [:asl] [:asl] [:asl] [:asl]
[:clc] [:adc #($1:lookup-addr :tiles)]])])
(fn enable-shadowing () (set! (word-at (ref :0xc035)) (& (word-at (ref :0xc035)) 0xfff1)))
(fn disable-shadowing () (set! (word-at (ref :0xc035)) (| (word-at (ref :0xc035)) 0x000e)))
(global word with-shadowing 0)
(fn draw-test-tiles (i)
(when with-shadowing (disable-shadowing))
(let (x 0 y 0 screen 0x2000)
(while (< y 12)
(draw-tile (itile-to-tile (& (+ x y i) 3)) screen)
@ -76,7 +100,24 @@
(do (set! x 0)
(set! y (+ y 1))
(set! screen (+ screen [(+ 8 (* 160 15))])))
(set! screen (+ screen 8))))))
(set! screen (+ screen 8)))))
(when with-shadowing
(enable-shadowing)
(if (= with-shadowing 1)
(let (x 0 y 0 screen 0x2000)
(while (< y 12)
(shadow-rewrite-tile screen)
(set! x (+ x 1))
(if (= x 20)
(do (set! x 0)
(set! y (+ y 1))
(set! screen (+ screen [(+ 8 (* 160 15))])))
(set! screen (+ screen 8)))))
(let (screen 0x9dff y 0)
(while (< y 200)
(draw-object screen pei-slam-scanline)
(set! screen (- screen 160))
(set! y (+ y 1)))))))
(fn draw-test-tiles-forever ()
(let (i 0)
@ -98,10 +139,14 @@
(SetAllSCBs 0)
(wait-for-key)
(enable-shadowing)
(let (tile-task (new-task (ref draw-test-tiles-forever)))
(wait-for-key)
(set! (word-at (ref :0xc035)) (& (word-at (ref :0xc035)) 0xf7))
(set! with-shadowing 1)
(wait-for-key)
(set! with-shadowing 2)
(wait-for-key)
(set! with-shadowing false)
(reset-task tile-task (ref yield-forever)))
(GrafOff)

19
ssc/iigs/bootstub.fnl
View file

@ -1,8 +1,14 @@
(import-macros {:sss ! : compile} :ssc.macros)
#(compile $1
(start-symbol boot)
(start-symbol boot-8)
(org 0x1000)
(fn boot-8 ()
(asm (clc) (xce) (rep 0x30) ; disable emulation mode, 16-bit index registers
(jsr boot)
(sec) (xce))) ; re-enter emulation mode
(org 0x060000)
(require ssc.iigs.toolbox)
(require ssc.task)
@ -11,12 +17,14 @@
(global long BootHandle-01)
(global long BootHandle-e0)
(global long BootHandle-e1)
(global long BootHandle-06)
(fn boot ()
(asm (clc) (xce) (rep 0x30)) ; disable emulation mode, 16-bit index registers
(asm (phk) (plb)) ; data currently lives in program bank
(save-dp-sp 0x0800)
(set-task-base 0x0800) ; space for 8 tasks
(save-6502-stack)
; http://www.1000bit.it/support/manuali/apple/technotes/pdos/tn.pdos.27.html
; When bootstrapping with no OS, we must reserve
(TLStartUp)
@ -25,6 +33,7 @@
(set! BootUserID (GetNewID 0x1f00))
(LoadOneTool ToolsetMemoryManager 0x0100)
(set! BootHandle-06 (NewHandle 0xffff BootUserID 0xb017 0x060000))
(set! BootHandle-00 (NewHandle 0xb800 BootUserID 0xb017 0x000800))
(set! BootHandle-01 (NewHandle 0xb800 BootUserID 0xb017 0x010800))
(set! BootHandle-e0 (NewHandle 0x4000 BootUserID 0xb017 0xe02000))
@ -36,12 +45,12 @@
(DisposeHandle BootHandle-e0)
(DisposeHandle BootHandle-01)
(DisposeHandle BootHandle-00)
(DisposeHandle BootHandle-06)
(DeleteID BootUserID)
(MTShutDown)
(restore-6502-stack)
(restore-dp-sp)
(asm (sec) (xce)) ; re-enter emulation mode
))
(asm (rtl))))

48
ssc/iigs/graphics.fnl Normal file
View file

@ -0,0 +1,48 @@
; IIgs graphical architecture:
; PREMISE: All small-scale bitmapped graphics are encoded as code that pushes the graphics onto the stack,
; which has been aligned to the appropriate place to draw said graphics.
; Jump tables are stored in the main code segment so that eg. tiles can be easily calculated by index, and
; so we don't have to explicitly pass longs to a regular function.
(import-macros {:sss ! : compile} :ssc.macros)
(local lume (require :lib.lume))
(local {: countiter} (require :lib.util))
#(compile $1
(global word draw-object-saved-stack 0)
(fn draw-object (screen object)
(asm (sei) ; disable interrupts
(lda object) (sta [{:abs #(+ ($1:lookup-addr :draw-object-current-object-jump) 1)}])
(tsc) (sta draw-object-saved-stack)
(lda screen) (tcs)
(lda :0xc068) (ora 0x30) (sta :0xc068) ; set altzp
draw-object-current-object-jump
(jmp draw-object)
draw-object-finished (export draw-object-finished)
(lda :0xc068) (and 0xffcf) (sta :0xc068) ; clear altzp
(lda draw-object-saved-stack) (tcs)
(cli))) ; enable interrupts
(form drawfn [(fn [ssc name ...]
(assert (not (ssc:defining?)) "drawfn must be defined at top level")
(set ssc.locals nil) ; locals cannot be used
(local asm (ssc:expr-poly (lume.concat [:do ...] [[:asm [:jmp :draw-object-finished]]])))
(set ssc.locals [])
(ssc:expr-poly [:form name (fn [ssc] (assert (= ssc.locals nil) (.. name " must be called from a drawfn")) [:jmp name])])
(ssc:expr-poly [:getter name [:ref name]])
(ssc.org:append name asm))])
(drawfn pei-slam-tile
(asm (tdc) (tax) ; store direct page register in X
(tsc) (sec) (sbc 255) (tcd)
[(lume.concat [:block] (icollect [_ (countiter 16)]
[(! block (pei (:d0xfe)) (pei (:d0xfc)) (pei (:d0xfa)) (pei (:d0xf8))
(tsc) (sbc 152) (tcs) (sbc 255) (tcd))]))]
(txa) (tcd))) ; restore direct page register
(drawfn pei-slam-scanline
(asm (tdc) (tax) ; store direct page register in X
(tsc) (sec) (sbc 255) (tcd)
[(lume.concat [:block] (icollect [offset (countiter 0xfe (- 0x100 160) -2)] [:pei [(.. :d offset)]]))]
(txa) (tcd))) ; restore direct page register
)

37
ssc/init.fnl
View file

@ -97,7 +97,7 @@
(fn Ssc.was-dropped [self localcount]
(set self.locals (lume.slice self.locals 1 (- (length self.locals) localcount))))
(fn Ssc.defining? [self] (> (length self.locals) 0))
(fn Ssc.defining? [self] (or (= self.locals nil) (> (length self.locals) 0)))
; operations that work on the accumulator, like adc or sbc
; optimization strategy: keep the current result in the accumulator, work from the stack or immediate values
@ -199,10 +199,12 @@
(fn Ssc.asm-localify [self block]
(icollect [_ inst (ipairs block)]
(match inst
(where [op loc ?off] (self:local-offset loc)) [op (+ (self:local-offset loc) (or ?off 0)) :s]
(where [op [loc ?off] :y] (self:local-offset loc)) [op [(+ (self:local-offset loc) (or ?off 0)) :s] :y]
[:block] (self:asm-localify inst)
_ inst)))
(where [op loc ?off] (and (= (type loc) :string) (self:local-offset loc)))
[op (+ (self:local-offset loc) (or ?off 0)) :s]
(where [op [loc ?off] :y] (and (= (type loc) :string) (self:local-offset loc)))
[op [(+ (self:local-offset loc) (or ?off 0)) :s] :y]
[:block] (self:asm-localify inst)
_ inst)))
(set Ssc.forms
{:asm (fn [self ...] (if (self:defining?) (self:asm-localify [:block ...]) (self.org:append (table.unpack (self:asm-localify [...])))))
@ -250,6 +252,7 @@
cl-false (if ?iffalse [[:bra :-if-done-] :-if-false- c-false :-if-done-]
[:-if-false-])]
(values (lume.concat block cl-false) etype)))
:when (lambda [self test ...] (self:expr-poly [:if test [:do ...]]))
:while (lambda [self test ...]
(let [block [:block :-loop-top- (self:gen-condition test :-enter-loop- :-exit-loop-) :-enter-loop-]
c-body (self:expr-poly [:do ...])]
@ -271,7 +274,7 @@
(if (and (= etype :word) (>= opgen.const -2) (<= opgen.const 2))
(match opgen.const -1 [:inc] -2 [:block [:inc] [:inc]]
1 [:dec] 2 [:block [:dec] [:dec]])
[:block [:clc] (self:simple-accumulator :adc etype opgen)]))
[:block [:sec] (self:simple-accumulator :sbc etype opgen)]))
first ...)))
:| (lambda [self first ...] (self:accumulation-op #(self:simple-accumulator :ora $...) first ...))
:& (lambda [self first ...] (self:accumulation-op #(self:simple-accumulator :and $...) first ...))
@ -341,12 +344,13 @@
(fn Ssc.local-offset [self name-or-index]
(var offset nil)
(var stacklen 0)
(for [i 1 (length self.locals)]
(let [loc (. self.locals i)
size (match loc.type :placeholder 0 :word 2 :long 4 _ (error (.. "how big is this local??" (fv loc))))]
(set stacklen (+ stacklen size))
(when (or (= i name-or-index) (= loc.name name-or-index))
(set offset stacklen))))
(when self.locals
(for [i 1 (length self.locals)]
(let [loc (. self.locals i)
size (match loc.type :placeholder 0 :word 2 :long 4 _ (error (.. "how big is this local??" (fv loc))))]
(set stacklen (+ stacklen size))
(when (or (= i name-or-index) (= loc.name name-or-index))
(set offset stacklen)))))
(when offset (+ (- stacklen offset) 1)))
(fn Ssc.local-type [self name-or-index]
@ -443,7 +447,8 @@
(fn Ssc.expr-poly [self expr]
(self:enter-expr expr)
(let [(success c-expr etype)
(let [meta (or self.expr-metadata {:filename "<unknown>" :line "??"})
(success c-expr etype)
(pcall #(match expr
(where lit (?. (self:opgen lit) :hi)) (let [{: lo : hi} (self:opgen lit)]
(values [:block (lo :lda) [:sta self.LONG_LO] (hi :lda) [:sta self.LONG_HI]] :long))
@ -458,9 +463,9 @@
(values cexpr (or etype :word)))
nil (values [:block] :void)
_ (error (.. "Unrecognized expression"))))]
(if success (values c-expr etype)
(let [{: filename : line} (or self.expr-metadata {:filename "<unknown>" :line "??"})]
(error (.. filename "@" line ": " c-expr "\n" (fv expr)))))))
(if success (do (when (and c-expr (= (getmetatable c-expr) nil)) (setmetatable c-expr meta))
(values c-expr etype))
(let [{: filename : line} meta] (error (.. filename "@" line ": " c-expr "\n" (fv expr)))))))
(fn Ssc.expr-word [self expr]
(let [(c etype) (self:expr-poly expr)]

4
ssc/task.fnl
View file

@ -11,8 +11,8 @@
(form save-dp-sp [#[:block [:tdc] [:sta :old-dp] [:tsc] [:sta :old-sp]]])
(form restore-dp-sp [#[:block [:lda :old-dp] [:tcd] [:lda :old-sp] [:tcs]]])
(form save-6502-stack [#[:block [:tsc] [:tay] [:and 0xff] [:ora 0x100] [:tax] [:eor 0xffff] [:clc] [:adc 0x200] [:mvn 0 0]]])
(form restore-6502-stack [#[:block [:tsc] [:tax] [:and 0xff] [:ora 0x100] [:tay] [:eor 0xffff] [:clc] [:adc 0x200] [:mvn 0 0]]])
(form save-6502-stack [#[:block [:tsc] [:tay] [:and 0xff] [:ora 0x100] [:tax] [:eor 0xffff] [:clc] [:adc 0x200] [:phb] [:mvn 0 0] [:plb]]])
(form restore-6502-stack [#[:block [:tsc] [:tax] [:and 0xff] [:ora 0x100] [:tay] [:eor 0xffff] [:clc] [:adc 0x200] [:phb] [:mvn 0 0] [:plb]]])
; 0x1ef = 0x1ef-0x1ff = 0x0f -> 0x7f
(const task-size 0x100)
(global word first-task)