Restructure for more reliable reload, modularity

This commit is contained in:
Jeremy Penner 2020-10-05 23:47:25 -04:00
parent a524f23dfe
commit 3c22f6fe2e
7 changed files with 664 additions and 628 deletions

264
asm.fnl
View file

@ -1,6 +1,5 @@
(local lume (require "lume")) (local lume (require "lume"))
(local {: stream : kvstream : one} (require "stream")) (local {: int8-to-bytes : int16-to-bytes} (require "util"))
(local opcodes {}) (local opcodes {})
; op mode arg ; op mode arg
@ -33,7 +32,7 @@
modemap)) modemap))
(fn without-modes [modemap ...] (fn without-modes [modemap ...]
(let [newmodemap (table.clone modemap)] (let [newmodemap (lume.clone modemap)]
(each [_ mode (pairs [...])] (each [_ mode (pairs [...])]
(tset newmodemap mode nil)) (tset newmodemap mode nil))
newmodemap)) newmodemap))
@ -89,43 +88,6 @@
[_] [nil nil] [_] [nil nil]
_ (error (.. "Unrecognized syntax" (fv op))))) _ (error (.. "Unrecognized syntax" (fv op)))))
; dat - anything that takes up space in the assembled output (op, dw, db, etc)
; takes the form [:op args]
; pdat - a parsed dat; takes the form {:type type :addr addr ...}
(local dat-parser {})
(fn new-block [] {:type :block :pdats [] :symbols {}})
(fn parse-dats [block dats]
(each [_ dat (ipairs dats)]
(if (= (type dat) "string")
(tset block.symbols dat (+ (length block.pdats) 1))
(let [opcode (. dat 1)
parser (. dat-parser opcode)
pdat
(if
parser (parser dat block)
(. opcodes opcode) (dat-parser.op dat)
(error (.. "Unrecognized opcode " (fv opcode))))]
(table.insert block.pdats pdat))))
block)
(fn dat-parser.op [op]
(let [[mode arg] (parse-mode-arg op)]
{:type :op :opcode (. op 1) : mode : arg}))
(fn dat-parser.block [block]
(let [dats (table.clone block)]
(table.remove dats 1)
(parse-dats (new-block) dats)))
(fn dat-parser.db [db] {:type :var :init (. db 2) :size 1})
(fn dat-parser.dw [dw] {:type :var :init (. dw 2) :size 2})
(fn dat-parser.bytes [bytes] {:type :raw :bytes (. bytes 2)})
(fn dat-parser.ref [ref] {:type :ref :target (. ref 2)})
(fn dat-parser.flatten [flat block]
(parse-dats block (lume.slice flat 2))
nil)
(fn make-env [block parent] (fn make-env [block parent]
{:parent parent {:parent parent
:block block :block block
@ -153,102 +115,136 @@
(self.parent:lookup-addr name)))}) (self.parent:lookup-addr name)))})
(fn lo [v] (bit.band v 0xff))
(fn hi [v] (bit.band (bit.rshift v 8) 0xff))
(fn int8-to-bytes [i]
(string.char (lo i)))
(fn int16-to-bytes [i]
(string.char (lo i) (hi i)))
(local pdat-processor {
:op {}
:var {}
:ref {}
:raw {}
:block {}
})
(fn process-pdat [pdat process default ...]
(pp pdat)
(local processor (. pdat-processor pdat.type process))
(if processor (processor pdat ...) default))
(fn pdat-processor.op.patch [op env]
(when (and op.mode (= (op.mode:sub 1 4) :addr))
(let [zp-mode (.. :zp (op.mode:sub 5))
abs-mode (.. :abs (op.mode:sub 5))
is-zp (and ((. opcodes op.opcode) zp-mode) (env:is-zp? op.arg))]
(set op.mode (if is-zp zp-mode abs-mode)))))
(fn pdat-processor.raw.size [raw] (length raw.bytes))
(fn pdat-processor.op.size [op] (size op.mode))
(fn pdat-processor.var.size [d] d.size)
(fn pdat-processor.ref.size [r] 2)
(fn pdat-processor.op.bytes [op env]
(local bytegen (. opcodes op.opcode))
; (pp op)
(if bytegen
(let [opbyte (bytegen op.mode)
argbytes
(if
(and (= op.mode :imm) (= (type op.arg) "function"))
(int8-to-bytes (op.arg env))
(= op.mode :imm) (int8-to-bytes op.arg)
(= op.mode :rel)
(int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2)))
(= (size op.mode) 2) (int8-to-bytes (env:lookup-addr op.arg))
(= (size op.mode) 3) (int16-to-bytes (env:lookup-addr op.arg))
"")]
(if opbyte
(.. (int8-to-bytes opbyte) argbytes)
(error (.. op.opcode " doesn't support mode " op.mode))))
""))
(fn pdat-processor.var.bytes [d env]
(match d.size
1 (int8-to-bytes (or d.init 0))
2 (int16-to-bytes (or d.init 0))
n (string.rep "\0" n)))
(fn pdat-processor.ref.bytes [ref env]
(int16-to-bytes (env:lookup-addr ref.target)))
(fn pdat-processor.block.symbols [block]
(lume.keys block.symbols))
(fn pdat-processor.block.patch [block env]
(local block-env (make-env block env))
(each [_ pdat (ipairs block.pdats)]
(process-pdat pdat :patch nil block-env)))
(fn pdat-processor.block.allocate [block addr]
(var size 0)
(set block.addr addr)
(each [_ pdat (ipairs block.pdats)]
(set pdat.addr (+ addr size))
(process-pdat pdat :allocate nil pdat.addr)
(local pdatsize (process-pdat pdat :size pdat.size))
(set pdat.size pdatsize)
(set pdat.addr (+ addr size))
(set size (+ size pdatsize)))
(set block.size size))
(fn pdat-processor.block.generate [block env]
(local block-env (make-env block env))
(var bytes "")
(each [_ pdat (ipairs block.pdats)]
(process-pdat pdat :generate nil block-env)
(local pdatbytes (process-pdat pdat :bytes pdat.bytes block-env))
(assert (= (type pdatbytes) :string) (.. "failed to generate bytes: " (fv pdat)))
(set pdat.bytes pdatbytes)
(set bytes (.. bytes pdatbytes)))
(set block.bytes bytes))
(fn program [] (fn program []
; dat - anything that takes up space in the assembled output (op, dw, db, etc)
; takes the form [:op args]
; pdat - a parsed dat; takes the form {:type type :addr addr ...}
(local dat-parser {})
(fn new-block [] {:type :block :pdats [] :symbols {}})
(fn parse-dats [block dats]
(each [_ dat (ipairs dats)]
(if (= (type dat) "string")
(tset block.symbols dat (+ (length block.pdats) 1))
(let [opcode (. dat 1)
parser (. dat-parser opcode)
pdat
(if
parser (parser dat block)
(. opcodes opcode) (dat-parser.op dat)
(error (.. "Unrecognized opcode " (fv opcode))))]
(table.insert block.pdats pdat))))
block)
(fn dat-parser.op [op]
(let [[mode arg] (parse-mode-arg op)]
{:type :op :opcode (. op 1) : mode : arg}))
(fn dat-parser.block [block]
(let [dats (lume.clone block)]
(table.remove dats 1)
(parse-dats (new-block) dats)))
(fn dat-parser.db [db] {:type :var :init (. db 2) :size 1})
(fn dat-parser.dw [dw] {:type :var :init (. dw 2) :size 2})
(fn dat-parser.bytes [bytes] {:type :raw :bytes (. bytes 2)})
(fn dat-parser.ref [ref] {:type :ref :target (. ref 2)})
(fn dat-parser.flatten [flat block]
(parse-dats block (lume.slice flat 2))
nil)
(local pdat-processor {
:op {}
:var {}
:ref {}
:raw {}
:block {}
})
(fn process-pdat [pdat process default ...]
(pp pdat)
(local processor (. pdat-processor pdat.type process))
(if processor (processor pdat ...) default))
(fn pdat-processor.op.patch [op env]
(when (and op.mode (= (op.mode:sub 1 4) :addr))
(let [zp-mode (.. :zp (op.mode:sub 5))
abs-mode (.. :abs (op.mode:sub 5))
is-zp (and ((. opcodes op.opcode) zp-mode) (env:is-zp? op.arg))]
(set op.mode (if is-zp zp-mode abs-mode)))))
(fn pdat-processor.raw.size [raw] (length raw.bytes))
(fn pdat-processor.op.size [op] (size op.mode))
(fn pdat-processor.var.size [d] d.size)
(fn pdat-processor.ref.size [r] 2)
(fn pdat-processor.op.bytes [op env]
(local bytegen (. opcodes op.opcode))
; (pp op)
(if bytegen
(let [opbyte (bytegen op.mode)
argbytes
(if
(and (= op.mode :imm) (= (type op.arg) "function"))
(int8-to-bytes (op.arg env))
(= op.mode :imm) (int8-to-bytes op.arg)
(= op.mode :rel)
(int8-to-bytes (- (env:lookup-addr op.arg) (+ op.addr 2)))
(= (size op.mode) 2) (int8-to-bytes (env:lookup-addr op.arg))
(= (size op.mode) 3) (int16-to-bytes (env:lookup-addr op.arg))
"")]
(if opbyte
(.. (int8-to-bytes opbyte) argbytes)
(error (.. op.opcode " doesn't support mode " op.mode))))
""))
(fn pdat-processor.var.bytes [d env]
(match d.size
1 (int8-to-bytes (or d.init 0))
2 (int16-to-bytes (or d.init 0))
n (string.rep "\0" n)))
(fn pdat-processor.ref.bytes [ref env]
(int16-to-bytes (env:lookup-addr ref.target)))
(fn pdat-processor.block.symbols [block]
(lume.keys block.symbols))
(fn pdat-processor.block.patch [block env]
(local block-env (make-env block env))
(each [_ pdat (ipairs block.pdats)]
(process-pdat pdat :patch nil block-env)))
(fn pdat-processor.block.allocate [block addr]
(var size 0)
(set block.addr addr)
(each [_ pdat (ipairs block.pdats)]
(set pdat.addr (+ addr size))
(process-pdat pdat :allocate nil pdat.addr)
(local pdatsize (process-pdat pdat :size pdat.size))
(set pdat.size pdatsize)
(set pdat.addr (+ addr size))
(set size (+ size pdatsize)))
(set block.size size))
(fn pdat-processor.block.generate [block env]
(local block-env (make-env block env))
(var bytes "")
(each [_ pdat (ipairs block.pdats)]
(process-pdat pdat :generate nil block-env)
(local pdatbytes (process-pdat pdat :bytes pdat.bytes block-env))
(assert (= (type pdatbytes) :string) (.. "failed to generate bytes: " (fv pdat)))
(set pdat.bytes pdatbytes)
(set bytes (.. bytes pdatbytes)))
(set block.bytes bytes))
{:type :program {:type :program
:org-to-block {} :org-to-block {}
:symbol-to-org {} :symbol-to-org {}
:start-symbol :main :start-symbol :main
: dat-parser
: pdat-processor
: new-block
:parse-dats (fn [self block dats] (parse-dats block dats))
:dbg :dbg
(fn [self ...] (fn [self ...]
(when self.dbgfile (when self.dbgfile
@ -311,12 +307,12 @@
(self:pass :generate) (self:pass :generate)
(when self.dbgfile (when self.dbgfile
(self.dbgfile:close) (self.dbgfile:close)
(set self.dbgfile nil))) (set self.dbgfile nil))
self)
:upload :upload
(fn [self machine] (fn [self machine]
(each [org block (pairs self.org-to-block)] (each [org block (pairs self.org-to-block)]
(machine:write org block.bytes))) (machine:write org block.bytes)))
}) })
{: program : dat-parser : pdat-processor : new-block : parse-dats : lo : hi} {:new program}

View file

@ -6,11 +6,6 @@ pp = function(x) print(fv(x)) end
lume = require("lume") lume = require("lume")
luars232 = require("luars232") luars232 = require("luars232")
function reload(modname)
package.loaded[modname] = nil
return require(modname)
end
_coroutine_resume = coroutine.resume _coroutine_resume = coroutine.resume
function coroutine.resume(...) function coroutine.resume(...)
local state,result = _coroutine_resume(...) local state,result = _coroutine_resume(...)

156
neut.fnl Normal file
View file

@ -0,0 +1,156 @@
(local lume (require "lume"))
(local asm (require "asm"))
(local VM (require "vm"))
(local {: lo : hi} (require "util"))
(local prg (asm.new))
; (prg:debug-to "test.dbg")
(local tiles (prg:org 0x6100))
(local vm (VM.new prg))
(local code1 vm.code)
(local mon {
:hexout :0xfdda
:putchar :0xfded
:bell :0xff3a
})
(fn achar [c] (bit.bor (string.byte c) 0x80))
(fn astr [s]
(-> [(string.byte s 1 -1)]
(lume.map #(bit.bor $1 0x80))
(-> (table.unpack) (string.char))))
; a handful of debugging words
(vm:def :.
[:lda vm.TOPH :x]
[:jsr mon.hexout]
[:lda vm.TOP :x]
[:jsr mon.hexout]
[:lda (achar " ")]
[:jsr mon.putchar]
(vm:drop))
(vm:def :stacklen
(vm:reserve)
[:txa] [:lsr :a] [:sta vm.TOP :x]
[:lda 0] [:sta vm.TOPH :x])
(vm:word :.s
:stacklen (prg:parse-addr vm.TOP) :swap
(vm:for :dup :get :. :inc :inc) :drop)
; Graphics routines
(vm:def :mixed-hires
[:sta :0xc050]
[:sta :0xc057]
[:sta :0xc052])
; starting address:
; 0x2000 + (x*2) + (y%4 * 0x100) + ((y/4) * 0x28)
; x between 0-19
; y between 0-12
; yx - 16-bit value, low byte x, high byte y
(code1:append :screeny-lookup [:bytes "\0\040\080"])
(vm:def :tile>screen ; yx -- p
[:lda vm.TOPH :x] ; a=y
[:lsr :a] [:lsr :a] ; a=y/4
[:tay] ; y=y/4
[:lda 0x03]
[:and vm.TOPH :x] ; a=y%4
[:ora 0x20] ; a=0x20 + y%4
[:sta vm.TOPH :x] ; high byte is set (and y is wiped)
[:lda vm.TOP :x] ; a=x
[:asl :a] ; a = x*2
[:clc]
[:adc :screeny-lookup :y] ; a=x*2 + (y/4)*0x28
[:sta vm.TOP :x] ; low byte is set
)
; note: the graphical tile data must not cross a page boundary!
; TODO: add support to the assembler for enforcing that
(fn draw-block []
[:block
[:clc]
[:ldy 8]
:loop
[:lda [vm.TOP :x]]
[:sta [vm.ST1 :x]]
[:inc vm.TOP :x]
[:lda vm.ST1H :x]
[:adc 4]
[:sta vm.ST1H :x]
[:dey]
[:bne :loop]])
(fn draw-vertical-block []
[:block
(draw-block)
[:lda vm.ST1H :x]
[:sbc 31] ; with carry clear this is 32
[:sta vm.ST1H :x]
[:lda vm.ST1 :x]
[:ora 0x80]
[:sta vm.ST1 :x]
(draw-block)])
(vm:def :drawtile ; p gfx --
(draw-vertical-block)
[:lda vm.ST1H :x]
[:sbc 31]
[:sta vm.ST1H :x]
[:lda vm.ST1 :x]
[:sbc 0x7f]
[:sta vm.ST1 :x]
(draw-vertical-block)
(vm:drop) (vm:drop))
(vm:def :cleargfx
(vm:push 0x4000)
[:block :page
[:dec vm.TOPH :x]
[:lda 0]
[:block :start
[:sta [vm.TOP :x]]
[:inc vm.TOP :x]
[:bne :start]]
[:lda vm.TOPH :x]
[:cmp 0x20]
[:bne :page]]
(vm:drop))
(vm:word :drawmaprow ; pscreen pmap -- pmap
20 (vm:for
:2dup :bget :lookup-tile :drawtile
:inc :swap :inc :inc :swap) :swap :drop)
(vm:word :drawmap
:lit :map 0x0c00 (vm:until 0x100 :-
:dup :tile>screen ; pmap yx pscreen
:<rot :drawmaprow :swap ; pmap yx
:dup :not) :drop :drop)
(vm:def :lookup-tile ; itile -- ptile
; each tile is 32 bytes; 2^5
; we save some cycles by storing the indices as lllhhhhh, so we don't need to shift them'
[:lda vm.TOP :x] [:tay]
[:and 0x1f]
[:clc] [:adc #(hi tiles.org)]
[:sta vm.TOPH :x]
[:tya] [:and 0xe0]
[:sta vm.TOP :x])
(tiles:append :blanktile [:bytes "\0\0\0\0\0\0\0\0\0\255\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0 \0\0\0\0\0\0"])
(tiles:append :testtile [:bytes "12345678901234567890123456789012"])
(tiles:append [:bytes "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz"])
;; 19x11 means full map is 209 bytes
(: (prg:org 0x6800) :append :map [:bytes (string.rep "\0\032\064" 85)])
(code1:append :main
[:jsr :reset]
[:jsr :interpret]
[:vm :mixed-hires
:cleargfx :drawmap
:quit])
(prg:assemble)

479
test.fnl
View file

@ -1,479 +0,0 @@
(local lume (require "lume"))
(local {: program : dat-parser : new-block : parse-dats : lo : hi} (require "asm"))
(local {: stream : kvstream : one} (require "stream"))
(local prg (program))
(local code1 (prg:org 0xc00))
(local tiles (prg:org 0x6100))
(prg:debug-to "test.dbg")
(fn dat-parser.vm [bytecodes]
(local block (new-block))
(each [_ bytecode (ipairs (lume.slice bytecodes 2))]
(if
(= (type bytecode) :number)
(parse-dats block [[:ref :lit] [:dw bytecode]])
(= (type bytecode) :string)
(parse-dats block [[:ref bytecode]])
(= (type bytecode) :table)
(parse-dats block [bytecode])
(error (.. "VM can't parse " (fv bytecode)))))
block)
(local mon {
:hexout :0xfdda
:putchar :0xfded
:bell :0xff3a
})
(local vm {
:IP :0x60
:IPH :0x61
:W :0x62
:WH :0x63
:ROFF :0x64
:TOP :0x80
:TOPH :0x81
:ST1 :0x7e
:ST1H :0x7f
:ST2 :0x7c
:ST2H :0x7d
:RSTACK :0x6000
:ret (fn [self] [:jmp :next])
:reserve (fn [self] [:block [:inx] [:inx]])
:push
(fn [self v]
(local l (bit.band v 0xff))
(local h (bit.band (bit.rshift v 8) 0xff))
[:block (self:reserve)
[:lda l]
[:sta self.TOP :x]
[:lda h]
[:sta self.TOPH :x]
])
:drop (fn [self] [:block [:dex] [:dex]])
:def
(fn [self name ...]
(code1:append name [:flatten ...] (self:ret)))
:word
(fn [self name ...]
(code1:append name [:jsr :subroutine] [:vm ...] [:vm :ret]))
:inline
(fn [self ...]
[:block [:jsr :subroutine] [:vm ...] [:vm :restore]])
:asm
(fn [self ...]
[:block [:vm :native] [:block ...] [:jsr :interpret]])
})
(fn inc16 [l h]
[:block
[:inc l]
[:bne :done]
[:inc h]
:done
])
(fn dec16 [l h]
[:block
[:lda l]
[:bne :declow]
[:dec h]
:declow
[:dec l]])
(fn add16 [l h]
[:block
[:clc]
[:adc l]
[:sta l]
[:bcc :go]
[:inc h]
:go
])
(fn inc16-stk [l h]
[:block
[:inc l :x]
[:bne :done]
[:inc h :x]
:done])
(fn achar [c] (bit.bor (string.byte c) 0x80))
(fn astr [s]
(-> [(string.byte s 1 -1)]
(lume.map #(bit.bor $1 0x80))
(-> (table.unpack) (string.char))))
(code1:append :next
[:ldy 0]
[:lda [vm.IP] :y] [:sta vm.W]
(inc16 vm.IP vm.IPH)
[:lda [vm.IP] :y] [:sta vm.WH]
(inc16 vm.IP vm.IPH)
; [:lda vm.WH]
; [:jsr mon.hexout]
; [:lda vm.W]
; [:jsr mon.hexout]
; [:lda (achar " ")]
; [:jsr mon.putchar]
[:jmp [vm.W]])
(code1:append :reset
[:lda #(lo ($1:lookup-addr :quit))]
[:sta vm.IP]
[:lda #(hi ($1:lookup-addr :quit))]
[:sta vm.IPH]
[:lda 0]
[:sta vm.ROFF]
[:ldx 0xfe]
[:rts])
(vm:def
:subroutine ; usage: [jsr :subroutine] followed by bytecode
[:ldy vm.ROFF]
[:lda vm.IP] [:sta vm.RSTACK :y] [:iny]
[:lda vm.IPH] [:sta vm.RSTACK :y] [:iny]
[:sty vm.ROFF]
:interpret ; usage: [jsr :interpret] followed by bytecode
[:pla] [:sta vm.IP] [:pla] [:sta vm.IPH]
(inc16 vm.IP vm.IPH))
(vm:def :ret
[:ldy vm.ROFF]
[:dey] [:lda vm.RSTACK :y] [:sta vm.IPH]
[:dey] [:lda vm.RSTACK :y] [:sta vm.IP]
[:sty vm.ROFF])
(code1:append :native [:jmp [vm.IP]])
(code1:append :quit [:rts])
(code1:append :restore
[:lda vm.IP] [:sta vm.W]
[:lda vm.IPH] [:sta vm.WH]
[:ldy vm.ROFF]
[:dey] [:lda vm.RSTACK :y] [:sta vm.IPH]
[:dey] [:lda vm.RSTACK :y] [:sta vm.IP]
[:sty vm.ROFF]
[:jmp [vm.W]])
(vm:def :mixed-hires
[:sta :0xc050]
[:sta :0xc057]
[:sta :0xc052])
(vm:def :drop (vm:drop))
(vm:def :dup
(vm:reserve)
[:lda vm.ST1H :x]
[:sta vm.TOPH :x]
[:lda vm.ST1 :x]
[:sta vm.TOP :x])
(vm:def :swap
[:lda vm.TOP :x]
[:ldy vm.ST1 :x]
[:sty vm.TOP :x]
[:sta vm.ST1 :x]
[:lda vm.TOPH :x]
[:ldy vm.ST1H :x]
[:sty vm.TOPH :x]
[:sta vm.ST1H :x])
(vm:def :over
(vm:reserve)
[:lda vm.ST2H :x]
[:sta vm.TOPH :x]
[:lda vm.ST2 :x]
[:sta vm.TOP :x])
(vm:word :2dup :over :over)
(vm:def :>rot ; (a b c -- c a b)
[:lda vm.TOP :x] ; a: c (a b c)
[:ldy vm.ST2 :x] ; y: a (a b c)
[:sta vm.ST2 :x] ; a: c (c b c)
[:lda vm.ST1 :x] ; a: b (c b c)
[:sta vm.TOP :x] ; a: b (c b b)
[:sty vm.ST1 :x] ; y: a (c a b)
[:lda vm.TOPH :x] ; a: c (a b c)
[:ldy vm.ST2H :x] ; y: a (a b c)
[:sta vm.ST2H :x] ; a: c (c b c)
[:lda vm.ST1H :x] ; a: b (c b c)
[:sta vm.TOPH :x] ; a: b (c b b)
[:sty vm.ST1H :x] ; y: a (c a b)
)
(vm:def :<rot ; (a b c -- b c a)
[:lda vm.TOP :x] ; a: c (a b c)
[:ldy vm.ST1 :x] ; y: b (a b c)
[:sta vm.ST1 :x] ; a: c (a c c)
[:lda vm.ST2 :x] ; a: a (a c c)
[:sta vm.TOP :x] ; a: a (a c a)
[:sty vm.ST2 :x] ; y: b (b c a)
[:lda vm.TOPH :x] ; a: c (a b c)
[:ldy vm.ST1H :x] ; y: b (a b c)
[:sta vm.ST1H :x] ; a: c (a c c)
[:lda vm.ST2H :x] ; a: a (a c c)
[:sta vm.TOPH :x] ; a: a (a c a)
[:sty vm.ST2H :x] ; y: b (b c a)
)
(vm:def :get
[:lda [vm.TOP :x]]
[:tay]
(inc16-stk vm.TOP vm.TOPH)
[:lda [vm.TOP :x]]
[:sta vm.TOPH :x]
[:sty vm.TOP :x])
(vm:def :set ; v p --
[:lda vm.ST1 :x]
[:sta [vm.TOP :x]]
(inc16-stk vm.TOP vm.TOPH)
[:lda vm.ST1H :x]
[:sta [vm.TOP :x]]
(vm:drop) (vm:drop))
(vm:def :bget ; p -- b
[:lda [vm.TOP :x]] [:sta vm.TOP :x]
[:lda 0] [:sta vm.TOPH :x])
(vm:def :bset ; b p --
[:lda vm.ST1 :x] [:sta [vm.TOP :x]]
(vm:drop) (vm:drop))
(vm:def :lit
(vm:reserve) [:ldy 0]
[:lda [vm.IP] :y] [:sta vm.TOP :x]
(inc16 vm.IP vm.IPH)
[:lda [vm.IP] :y] [:sta vm.TOPH :x]
(inc16 vm.IP vm.IPH))
(vm:def :>r ; v --
[:ldy vm.ROFF]
[:lda vm.TOP :x] [:sta vm.RSTACK :y] [:iny]
[:lda vm.TOPH :x] [:sta vm.RSTACK :y] [:iny]
[:sty vm.ROFF]
(vm:drop))
(vm:def :r> ; -- v
(vm:reserve)
[:ldy vm.ROFF]
[:dey] [:lda vm.RSTACK :y] [:sta vm.TOPH :x]
[:dey] [:lda vm.RSTACK :y] [:sta vm.TOP :x]
[:sty vm.ROFF])
(vm:def :rtop ; -- v
(vm:reserve)
[:ldy vm.ROFF]
[:dey] [:lda vm.RSTACK :y] [:sta vm.TOPH :x]
[:dey] [:lda vm.RSTACK :y] [:sta vm.TOP :x])
(vm:def :rdrop
[:ldy vm.ROFF] [:dey] [:dey] [:sty vm.ROFF])
(vm:def :bz ; f --
[:block
[:lda vm.TOP :x]
[:bne :skip]
[:lda vm.TOPH :x]
[:beq :dojmp]
:skip
(vm:drop)
[:lda 2] (add16 vm.IP vm.IPH) (vm:ret)
:dojmp (vm:drop)]
:jmp
; ugh I don't have enough registers for this; a (one-byte?) relative jump would maybe be better
[:ldy 0] [:lda [vm.IP] :y] [:sta vm.W]
[:iny] [:lda [vm.IP] :y] [:sta vm.IPH]
[:lda vm.W] [:sta vm.IP])
(fn vm.while [self preamble ...]
[:block
:start
[:vm (table.unpack preamble)]
[:ref :bz] [:ref :end]
[:vm ...]
[:ref :jmp] [:ref :start]
:end])
(fn vm.until [self ...]
[:block :start [:vm ...] [:ref :bz] [:ref :start]])
(fn vm.for [self ...]
[:vm :>r (vm:while [:rtop] [:vm ...] :r> :dec :>r) :rdrop])
(vm:def :+ ; a b -- c
[:clc]
[:lda vm.ST1 :x] [:adc vm.TOP :x] [:sta vm.ST1 :x]
[:lda vm.ST1H :x] [:adc vm.TOPH :x] [:sta vm.ST1H :x]
(vm:drop))
(vm:def :- ; a b -- c
[:sec]
[:lda vm.ST1 :x] [:sbc vm.TOP :x] [:sta vm.ST1 :x]
[:lda vm.ST1H :x] [:sbc vm.TOPH :x] [:sta vm.ST1H :x]
(vm:drop))
(vm:def :inc ; a -- a+1
(inc16-stk vm.TOP vm.TOPH))
(vm:def :dec ; a -- a-1
[:block
[:lda vm.TOP :x]
[:bne :declow]
[:dec vm.TOPH :x]
:declow
[:dec vm.TOP :x]])
(vm:def :not ; f - !f
[:block
[:lda vm.TOP :x]
[:bne :zero]
[:lda vm.TOPH :x]
[:bne :zero]
[:lda 0xff] [:sta vm.TOP :x] [:sta vm.TOPH :x] (vm:ret)
:zero
[:lda 0] [:sta vm.TOP :x] [:sta vm.TOPH :x]])
(vm:def := ; a b -- f
[:block
[:lda vm.ST1 :x]
[:cmp vm.TOP :x]
[:bne :noteq]
[:lda vm.ST1H :x]
[:cmp vm.TOP :x]
[:bne :noteq]
[:lda 0xff] (vm:drop) [:sta vm.TOP :x] [:sta vm.TOPH :x] (vm:ret)
:noteq
[:lda 0] (vm:drop) [:sta vm.TOP :x] [:sta vm.TOPH :x]])
(vm:def :.
[:lda vm.TOPH :x]
[:jsr mon.hexout]
[:lda vm.TOP :x]
[:jsr mon.hexout]
[:lda (achar " ")]
[:jsr mon.putchar]
(vm:drop))
(vm:def :stacklen
(vm:reserve)
[:txa] [:lsr :a] [:sta vm.TOP :x]
[:lda 0] [:sta vm.TOPH :x])
(vm:word :.s
:stacklen (prg:parse-addr vm.TOP) :swap
(vm:for :dup :get :. :inc :inc) :drop)
; starting address:
; 0x2000 + (x*2) + (y%4 * 0x100) + ((y/4) * 0x28)
; x between 0-19
; y between 0-12
; yx - 16-bit value, low byte x, high byte y
(code1:append :screeny-lookup [:bytes "\0\040\080"])
(vm:def :tile>screen ; yx -- p
[:lda vm.TOPH :x] ; a=y
[:lsr :a] [:lsr :a] ; a=y/4
[:tay] ; y=y/4
[:lda 0x03]
[:and vm.TOPH :x] ; a=y%4
[:ora 0x20] ; a=0x20 + y%4
[:sta vm.TOPH :x] ; high byte is set (and y is wiped)
[:lda vm.TOP :x] ; a=x
[:asl :a] ; a = x*2
[:clc]
[:adc :screeny-lookup :y] ; a=x*2 + (y/4)*0x28
[:sta vm.TOP :x] ; low byte is set
)
; note: the graphical tile data must not cross a page boundary!
; TODO: add support to the assembler for enforcing that
(fn draw-block []
[:block
[:clc]
[:ldy 8]
:loop
[:lda [vm.TOP :x]]
[:sta [vm.ST1 :x]]
[:inc vm.TOP :x]
[:lda vm.ST1H :x]
[:adc 4]
[:sta vm.ST1H :x]
[:dey]
[:bne :loop]])
(fn draw-vertical-block []
[:block
(draw-block)
[:lda vm.ST1H :x]
[:sbc 31] ; with carry clear this is 32
[:sta vm.ST1H :x]
[:lda vm.ST1 :x]
[:ora 0x80]
[:sta vm.ST1 :x]
(draw-block)])
(vm:def :drawtile ; p gfx --
(draw-vertical-block)
[:lda vm.ST1H :x]
[:sbc 31]
[:sta vm.ST1H :x]
[:lda vm.ST1 :x]
[:sbc 0x7f]
[:sta vm.ST1 :x]
(draw-vertical-block)
(vm:drop) (vm:drop))
(vm:def :cleargfx
(vm:push 0x4000)
[:block :page
[:dec vm.TOPH :x]
[:lda 0]
[:block :start
[:sta [vm.TOP :x]]
[:inc vm.TOP :x]
[:bne :start]]
[:lda vm.TOPH :x]
[:cmp 0x20]
[:bne :page]]
(vm:drop))
(vm:word :drawmaprow ; pscreen pmap -- pmap
20 (vm:for
:2dup :bget :lookup-tile :drawtile
:inc :swap :inc :inc :swap) :swap :drop)
(vm:word :drawmap
:lit :map 0x0c00 (vm:until 0x100 :-
:dup :tile>screen ; pmap yx pscreen
:<rot :drawmaprow :swap ; pmap yx
:dup :not) :drop :drop)
(vm:def :lookup-tile ; itile -- ptile
; each tile is 32 bytes; 2^5
; we save some cycles by storing the indices as lllhhhhh, so we don't need to shift them'
[:lda vm.TOP :x] [:tay]
[:and 0x1f]
[:clc] [:adc #(hi tiles.org)]
[:sta vm.TOPH :x]
[:tya] [:and 0xe0]
[:sta vm.TOP :x])
(tiles:append :blanktile [:bytes "\0\0\0\0\0\0\0\0\0\255\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0 \0\0\0\0\0\0"])
(tiles:append :testtile [:bytes "12345678901234567890123456789012"])
(tiles:append [:bytes "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz"])
;; 19x11 means full map is 209 bytes
(: (prg:org 0x6800) :append :map [:bytes (string.rep "\0\032\064" 85)])
(code1:append :main
[:jsr :reset]
[:jsr :interpret]
[:vm :mixed-hires
:cleargfx :drawmap
:quit])
(prg:assemble)
prg

View file

@ -1,9 +1,40 @@
(fn table.clone [tbl] (local lume (require "lume"))
(let [newtbl {}]
(each [k v (pairs tbl)]
(tset newtbl k v))
newtbl))
(fn string.fromhex [str] (fn string.fromhex [str]
(str:gsub ".." (fn [cc] (string.char (tonumber cc 16))))) (str:gsub ".." (fn [cc] (string.char (tonumber cc 16)))))
(fn string.tohex [str] (fn string.tohex [str]
(str:gsub "." (fn [c] (string.format "%02X" (string.byte c))))) (str:gsub "." (fn [c] (string.format "%02X" (string.byte c)))))
(fn lo [v] (bit.band v 0xff))
(fn hi [v] (bit.band (bit.rshift v 8) 0xff))
(fn int8-to-bytes [i]
(string.char (lo i)))
(fn int16-to-bytes [i]
(string.char (lo i) (hi i)))
(fn reload [modname]
(tset package.loaded modname nil)
(require modname))
; lume.hotswap really assumes your module is a table
(fn hotswap [modname]
(if (= (type (. package.loaded modname)) :table)
(lume.hotswap modname)
(reload modname)))
(fn mk-swappable-fn [table k]
(fn [...] ((. table k) ...)))
(fn swappable [table]
(local s {})
(each [k v (pairs table)]
(if (= (type v) :function)
(tset s k (mk-swappable-fn table k))
(tset s k v)))
s)
(fn swappable-require [modname]
(swappable (require modname)))
{: lo : hi : int8-to-bytes : int16-to-bytes : reload : hotswap : swappable :require swappable-require}

337
vm.fnl Normal file
View file

@ -0,0 +1,337 @@
(local lume (require "lume"))
(local {: lo : hi} (require "util"))
(fn inc16-stk [l h]
[:block
[:inc l :x]
[:bne :done]
[:inc h :x]
:done])
(fn inc16 [l h]
[:block
[:inc l]
[:bne :done]
[:inc h]
:done
])
(fn dec16 [l h]
[:block
[:lda l]
[:bne :declow]
[:dec h]
:declow
[:dec l]])
(fn add16 [l h]
[:block
[:clc]
[:adc l]
[:sta l]
[:bcc :go]
[:inc h]
:go
])
(fn mk-vm [prg options]
(local code1 (prg:org 0xc00))
(fn prg.dat-parser.vm [bytecodes]
(local block (prg:new-block))
(each [_ bytecode (ipairs (lume.slice bytecodes 2))]
(if
(= (type bytecode) :number)
(prg:parse-dats block [[:ref :lit] [:dw bytecode]])
(= (type bytecode) :string)
(prg:parse-dats block [[:ref bytecode]])
(= (type bytecode) :table)
(prg:parse-dats block [bytecode])
(error (.. "VM can't parse " (fv bytecode)))))
block)
(local vm {
:IP :0x60
:IPH :0x61
:W :0x62
:WH :0x63
:ROFF :0x64
:TOP :0x80
:TOPH :0x81
:ST1 :0x7e
:ST1H :0x7f
:ST2 :0x7c
:ST2H :0x7d
:RSTACK :0x6000
:code code1
:ret (fn [self] [:jmp :next])
:reserve (fn [self] [:block [:inx] [:inx]])
:push
(fn [self v]
(local l (bit.band v 0xff))
(local h (bit.band (bit.rshift v 8) 0xff))
[:block (self:reserve)
[:lda l]
[:sta self.TOP :x]
[:lda h]
[:sta self.TOPH :x]
])
:drop (fn [self] [:block [:dex] [:dex]])
:def
(fn [self name ...]
(code1:append name [:flatten ...] (self:ret)))
:word
(fn [self name ...]
(code1:append name [:jsr :subroutine] [:vm ...] [:vm :ret]))
:inline
(fn [self ...]
[:block [:jsr :subroutine] [:vm ...] [:vm :restore]])
:asm
(fn [self ...]
[:block [:vm :native] [:block ...] [:jsr :interpret]])
})
(code1:append :next
[:ldy 0]
[:lda [vm.IP] :y] [:sta vm.W]
(inc16 vm.IP vm.IPH)
[:lda [vm.IP] :y] [:sta vm.WH]
(inc16 vm.IP vm.IPH)
; [:lda vm.WH]
; [:jsr mon.hexout]
; [:lda vm.W]
; [:jsr mon.hexout]
; [:lda (achar " ")]
; [:jsr mon.putchar]
[:jmp [vm.W]])
(code1:append :reset
[:lda #(lo ($1:lookup-addr :quit))]
[:sta vm.IP]
[:lda #(hi ($1:lookup-addr :quit))]
[:sta vm.IPH]
[:lda 0]
[:sta vm.ROFF]
[:ldx 0xfe]
[:rts])
(vm:def
:subroutine ; usage: [jsr :subroutine] followed by bytecode
[:ldy vm.ROFF]
[:lda vm.IP] [:sta vm.RSTACK :y] [:iny]
[:lda vm.IPH] [:sta vm.RSTACK :y] [:iny]
[:sty vm.ROFF]
:interpret ; usage: [jsr :interpret] followed by bytecode
[:pla] [:sta vm.IP] [:pla] [:sta vm.IPH]
(inc16 vm.IP vm.IPH))
(vm:def :ret
[:ldy vm.ROFF]
[:dey] [:lda vm.RSTACK :y] [:sta vm.IPH]
[:dey] [:lda vm.RSTACK :y] [:sta vm.IP]
[:sty vm.ROFF])
(code1:append :native [:jmp [vm.IP]])
(code1:append :quit [:rts])
(code1:append :restore
[:lda vm.IP] [:sta vm.W]
[:lda vm.IPH] [:sta vm.WH]
[:ldy vm.ROFF]
[:dey] [:lda vm.RSTACK :y] [:sta vm.IPH]
[:dey] [:lda vm.RSTACK :y] [:sta vm.IP]
[:sty vm.ROFF]
[:jmp [vm.W]])
(vm:def :drop (vm:drop))
(vm:def :dup
(vm:reserve)
[:lda vm.ST1H :x]
[:sta vm.TOPH :x]
[:lda vm.ST1 :x]
[:sta vm.TOP :x])
(vm:def :swap
[:lda vm.TOP :x]
[:ldy vm.ST1 :x]
[:sty vm.TOP :x]
[:sta vm.ST1 :x]
[:lda vm.TOPH :x]
[:ldy vm.ST1H :x]
[:sty vm.TOPH :x]
[:sta vm.ST1H :x])
(vm:def :over
(vm:reserve)
[:lda vm.ST2H :x]
[:sta vm.TOPH :x]
[:lda vm.ST2 :x]
[:sta vm.TOP :x])
(vm:word :2dup :over :over)
(vm:def :>rot ; (a b c -- c a b)
[:lda vm.TOP :x] ; a: c (a b c)
[:ldy vm.ST2 :x] ; y: a (a b c)
[:sta vm.ST2 :x] ; a: c (c b c)
[:lda vm.ST1 :x] ; a: b (c b c)
[:sta vm.TOP :x] ; a: b (c b b)
[:sty vm.ST1 :x] ; y: a (c a b)
[:lda vm.TOPH :x] ; a: c (a b c)
[:ldy vm.ST2H :x] ; y: a (a b c)
[:sta vm.ST2H :x] ; a: c (c b c)
[:lda vm.ST1H :x] ; a: b (c b c)
[:sta vm.TOPH :x] ; a: b (c b b)
[:sty vm.ST1H :x] ; y: a (c a b)
)
(vm:def :<rot ; (a b c -- b c a)
[:lda vm.TOP :x] ; a: c (a b c)
[:ldy vm.ST1 :x] ; y: b (a b c)
[:sta vm.ST1 :x] ; a: c (a c c)
[:lda vm.ST2 :x] ; a: a (a c c)
[:sta vm.TOP :x] ; a: a (a c a)
[:sty vm.ST2 :x] ; y: b (b c a)
[:lda vm.TOPH :x] ; a: c (a b c)
[:ldy vm.ST1H :x] ; y: b (a b c)
[:sta vm.ST1H :x] ; a: c (a c c)
[:lda vm.ST2H :x] ; a: a (a c c)
[:sta vm.TOPH :x] ; a: a (a c a)
[:sty vm.ST2H :x] ; y: b (b c a)
)
(vm:def :get
[:lda [vm.TOP :x]]
[:tay]
(inc16-stk vm.TOP vm.TOPH)
[:lda [vm.TOP :x]]
[:sta vm.TOPH :x]
[:sty vm.TOP :x])
(vm:def :set ; v p --
[:lda vm.ST1 :x]
[:sta [vm.TOP :x]]
(inc16-stk vm.TOP vm.TOPH)
[:lda vm.ST1H :x]
[:sta [vm.TOP :x]]
(vm:drop) (vm:drop))
(vm:def :bget ; p -- b
[:lda [vm.TOP :x]] [:sta vm.TOP :x]
[:lda 0] [:sta vm.TOPH :x])
(vm:def :bset ; b p --
[:lda vm.ST1 :x] [:sta [vm.TOP :x]]
(vm:drop) (vm:drop))
(vm:def :lit
(vm:reserve) [:ldy 0]
[:lda [vm.IP] :y] [:sta vm.TOP :x]
(inc16 vm.IP vm.IPH)
[:lda [vm.IP] :y] [:sta vm.TOPH :x]
(inc16 vm.IP vm.IPH))
(vm:def :>r ; v --
[:ldy vm.ROFF]
[:lda vm.TOP :x] [:sta vm.RSTACK :y] [:iny]
[:lda vm.TOPH :x] [:sta vm.RSTACK :y] [:iny]
[:sty vm.ROFF]
(vm:drop))
(vm:def :r> ; -- v
(vm:reserve)
[:ldy vm.ROFF]
[:dey] [:lda vm.RSTACK :y] [:sta vm.TOPH :x]
[:dey] [:lda vm.RSTACK :y] [:sta vm.TOP :x]
[:sty vm.ROFF])
(vm:def :rtop ; -- v
(vm:reserve)
[:ldy vm.ROFF]
[:dey] [:lda vm.RSTACK :y] [:sta vm.TOPH :x]
[:dey] [:lda vm.RSTACK :y] [:sta vm.TOP :x])
(vm:def :rdrop
[:ldy vm.ROFF] [:dey] [:dey] [:sty vm.ROFF])
(vm:def :bz ; f --
[:block
[:lda vm.TOP :x]
[:bne :skip]
[:lda vm.TOPH :x]
[:beq :dojmp]
:skip
(vm:drop)
[:lda 2] (add16 vm.IP vm.IPH) (vm:ret)
:dojmp (vm:drop)]
:jmp
; ugh I don't have enough registers for this; a (one-byte?) relative jump would maybe be better
[:ldy 0] [:lda [vm.IP] :y] [:sta vm.W]
[:iny] [:lda [vm.IP] :y] [:sta vm.IPH]
[:lda vm.W] [:sta vm.IP])
(fn vm.while [self preamble ...]
[:block
:start
[:vm (table.unpack preamble)]
[:ref :bz] [:ref :end]
[:vm ...]
[:ref :jmp] [:ref :start]
:end])
(fn vm.until [self ...]
[:block :start [:vm ...] [:ref :bz] [:ref :start]])
(fn vm.for [self ...]
[:vm :>r (vm:while [:rtop] :r> :dec :>r ...) :rdrop])
(vm:def :+ ; a b -- c
[:clc]
[:lda vm.ST1 :x] [:adc vm.TOP :x] [:sta vm.ST1 :x]
[:lda vm.ST1H :x] [:adc vm.TOPH :x] [:sta vm.ST1H :x]
(vm:drop))
(vm:def :- ; a b -- c
[:sec]
[:lda vm.ST1 :x] [:sbc vm.TOP :x] [:sta vm.ST1 :x]
[:lda vm.ST1H :x] [:sbc vm.TOPH :x] [:sta vm.ST1H :x]
(vm:drop))
(vm:def :inc ; a -- a+1
(inc16-stk vm.TOP vm.TOPH))
(vm:def :dec ; a -- a-1
[:block
[:lda vm.TOP :x]
[:bne :declow]
[:dec vm.TOPH :x]
:declow
[:dec vm.TOP :x]])
(vm:def :not ; f - !f
[:block
[:lda vm.TOP :x]
[:bne :zero]
[:lda vm.TOPH :x]
[:bne :zero]
[:lda 0xff] [:sta vm.TOP :x] [:sta vm.TOPH :x] (vm:ret)
:zero
[:lda 0] [:sta vm.TOP :x] [:sta vm.TOPH :x]])
(vm:def := ; a b -- f
[:block
[:lda vm.ST1 :x]
[:cmp vm.TOP :x]
[:bne :noteq]
[:lda vm.ST1H :x]
[:cmp vm.TOP :x]
[:bne :noteq]
[:lda 0xff] (vm:drop) [:sta vm.TOP :x] [:sta vm.TOPH :x] (vm:ret)
:noteq
[:lda 0] (vm:drop) [:sta vm.TOP :x] [:sta vm.TOPH :x]])
vm)
{:new mk-vm}

View file

@ -1,5 +1,5 @@
(require "lite") (require "lite")
(require "util") (local util (require "util"))
(local lume (require "lume")) (local lume (require "lume"))
(local imgui (require "imgui")) (local imgui (require "imgui"))
(local serial (require "serial")) (local serial (require "serial"))
@ -19,12 +19,12 @@
}) })
(command.add #(machine:connected?) { (command.add #(machine:connected?) {
"honeylisp:upload" (fn [] "honeylisp:upload" (fn []
(local p (reload "test")) (local p (util.reload "neut"))
(p:upload machine) (p:upload machine)
(core.log (string.format "%x" (p:lookup-addr p.start-symbol)))) (core.log (string.format "%x" (p:lookup-addr p.start-symbol))))
}) })
(command.add (fn [] true) { (command.add (fn [] true) {
"honeylisp:rebuild" #(reload "test") "honeylisp:rebuild" #(util.reload "neut")
}) })
(fn selected-symbol [] (fn selected-symbol []
@ -52,11 +52,11 @@
(: :gsub "^data%." "") (: :gsub "^data%." "")
(: :gsub "%.init$" ""))) (: :gsub "%.init$" "")))
(core.log (.. "Hotswapping " modname)) (core.log (.. "Hotswapping " modname))
(local (mod err) (lume.hotswap modname)) (local (mod err) (util.hotswap modname))
(when (not= err nil) (print err) (error err))) (when (not= err nil) (print err) (error err)))
"honeylisp:address" (fn [] "honeylisp:address" (fn []
(local word (selected-symbol)) (local word (selected-symbol))
(local p (require "test")) (local p (require "neut"))
(core.log (string.format "%s %x" word (or (p:lookup-addr word) -1))) (core.log (string.format "%s %x" word (or (p:lookup-addr word) -1)))
) )
}) })