506 lines
13 KiB
Fennel
506 lines
13 KiB
Fennel
(local lume (require "lib.lume"))
|
|
(local {: lo : hi} (require "lib.util"))
|
|
(local link (require :link))
|
|
(local asm (require :asm.asm))
|
|
|
|
(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 install-vm-parser [prg]
|
|
(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))
|
|
|
|
(fn mk-vm [prg ?options]
|
|
(local options (or ?options {}))
|
|
(local code1 (prg:org (or options.org 0x4000)))
|
|
(install-vm-parser prg)
|
|
(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 :0x100
|
|
:true 0xffff
|
|
:false 0
|
|
:code code1
|
|
:nextsymid 1
|
|
: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 ...]
|
|
(self.code:append name [:flatten ...] (self:ret)))
|
|
:word
|
|
(fn [self name ...]
|
|
(self.code: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]])
|
|
:hotswap-sync
|
|
(fn [self ...]
|
|
(if link.machine.stub
|
|
(do
|
|
(link.machine:stub self.code :next
|
|
[:lda #(lo ($1:lookup-addr :G-POST-HOTSWAP-RESET))]
|
|
[:sta self.IP]
|
|
[:lda #(hi ($1:lookup-addr :G-POST-HOTSWAP-RESET))]
|
|
[:sta self.IPH]
|
|
[:jmp :next])
|
|
[:block [:vm :debug-stub :jmp :no-hotswap-reset [:block :G-POST-HOTSWAP-RESET] ...] :no-hotswap-reset])
|
|
[:block]))
|
|
})
|
|
(set prg.vm vm)
|
|
|
|
(vm.code: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)
|
|
|
|
[:jmp [vm.W]])
|
|
|
|
(vm.code: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])
|
|
|
|
(vm.code:append :native [:jmp [vm.IP]])
|
|
(vm.code:append :quit [:rts])
|
|
(vm.code: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.code:append :execute
|
|
[:lda vm.TOP :x] [:sta vm.W]
|
|
[:lda vm.TOPH :x] [:sta vm.WH]
|
|
(vm:drop)
|
|
[: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)
|
|
:bnz [:export :bnz]
|
|
[:lda vm.TOP :x]
|
|
[:bne :dojmp]
|
|
[:lda vm.TOPH :x]
|
|
[:beq :skip]
|
|
: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.forever [self ...]
|
|
[:block :_start [:vm ...] [:vm :jmp :_start]])
|
|
|
|
(fn vm.for [self ...]
|
|
[:vm :>r (vm:while [:rtop] :r> :dec :>r ...) :rdrop])
|
|
(fn vm.i [self] :rtop)
|
|
|
|
(fn vm.when [self ...]
|
|
[:block [:vm :bz :_end ...] :_end])
|
|
|
|
(fn vm.if [self iftrue iffalse]
|
|
[:block [:vm :bz :_else (table.unpack iftrue)] [:vm :jmp :_end] :_else [:vm (table.unpack iffalse)] :_end])
|
|
|
|
(fn vm.ifchain [self ...]
|
|
(local block [:block])
|
|
(local cases [...])
|
|
(for [i 1 (- (length cases) 1) 2]
|
|
(local (test action) (values (. cases i) (. cases (+ i 1))))
|
|
(table.insert block [:flatten
|
|
(.. :_case i)
|
|
[:vm (table.unpack test)]
|
|
[:vm :bz (.. :_case (+ 2 i)) (table.unpack action)]
|
|
[:vm :jmp :_end]]))
|
|
(table.insert block [:flatten
|
|
(.. :_case (length cases))
|
|
[:vm (table.unpack (. cases (length cases)))]
|
|
:_end])
|
|
block)
|
|
|
|
(fn vm.case [self ...]
|
|
(local block [:block])
|
|
(local cases [...])
|
|
(each [icase [case & action] (ipairs cases)]
|
|
(table.insert block (.. :_case icase))
|
|
(if (< icase (length cases))
|
|
(do (table.insert block [:vm :dup case := :bz (.. :_case (+ 1 icase)) :drop (table.unpack action)])
|
|
(table.insert block [:vm :jmp :_end]))
|
|
(do (table.insert block [:vm :drop (table.unpack action)])
|
|
(table.insert block :_end))))
|
|
block)
|
|
|
|
(fn vm.if-or [self clauses iftrue iffalse]
|
|
(local block [:block])
|
|
(each [_ clause (ipairs clauses)]
|
|
(table.insert block [:flatten [:vm (table.unpack clause)] [:vm :bnz :_whentrue]])) ; could bum two instructions here if no iffalse
|
|
(table.insert block [:flatten [:vm (table.unpack (or iffalse []))] [:vm :jmp :_end]])
|
|
(table.insert block [:flatten :_whentrue [:vm (table.unpack iftrue)] :_end])
|
|
block)
|
|
|
|
(fn vm.if-and [self clauses iftrue iffalse]
|
|
(local block [:block])
|
|
(each [_ clause (ipairs clauses)]
|
|
(table.insert block [:flatten [:vm (table.unpack clause)] [:vm :bz :_whenfalse]]))
|
|
(table.insert block [:flatten [:vm (table.unpack iftrue)] [:vm :jmp :_end]])
|
|
(table.insert block [:flatten :_whenfalse [:vm (table.unpack (or iffalse []))] :_end])
|
|
block)
|
|
|
|
(fn vm.gensym [self]
|
|
(local sym (.. "G-GEN-SYM-" self.nextsymid))
|
|
(set self.nextsymid (+ self.nextsymid 1))
|
|
sym)
|
|
|
|
(fn vm.anon [self ...]
|
|
(local sym (self:gensym))
|
|
(self.code:append sym ...)
|
|
[:vm :lit sym])
|
|
|
|
(fn vm.str [self str] (self:anon [:bytes str] [:db 0]))
|
|
|
|
(vm:def :$dovar ; usage: [jsr :$dovar] followed by reserved space
|
|
(vm:reserve)
|
|
[:pla] [:sta vm.TOP :x] [:pla] [:sta vm.TOPH :x]
|
|
(inc16-stk vm.TOP vm.TOPH))
|
|
|
|
(fn vm.var [self name init]
|
|
(self.code:append name [:jsr :$dovar]
|
|
[:hot-preserve (.. :G-HOT-PRESERVE- name)
|
|
(if (= (type init) :table) init
|
|
[:dw init])]))
|
|
|
|
(vm:def :$doconst ; usage: [jsr :$doconst] followed by two bytes
|
|
(vm:reserve)
|
|
[:pla] [:sta vm.W] [:pla] [:sta vm.WH]
|
|
[:ldy 1] [:lda [vm.W] :y] [:sta vm.TOP :x]
|
|
[:iny] [:lda [vm.W] :y] [:sta vm.TOPH :x])
|
|
|
|
(fn vm.const [self name val]
|
|
(self.code:append name [:jsr :$doconst]
|
|
(if (= (type val) :number) [:dw val] [:ref val])))
|
|
|
|
(fn vm.defer [self name ?init]
|
|
(self.code:append name [:jmp (or ?init :next)]))
|
|
|
|
(vm:word :redefine ; xp deferredxp --
|
|
1 :+ :set)
|
|
|
|
(fn vm.override-deferred-parent [self prg name redirect]
|
|
(local addr (prg.prg-base:lookup-addr name))
|
|
(local org (prg:org (+ addr 1)))
|
|
(org:append [:ref redirect]))
|
|
|
|
(vm:defer :interactive-eval-checkpoint)
|
|
|
|
(fn vm.gen-eval-prg [self vmcode]
|
|
(local eval-prg (asm.new self.code.prg))
|
|
(install-vm-parser eval-prg)
|
|
(local org (eval-prg:org self.code.org))
|
|
(org:append :code-to-eval
|
|
[:jsr :subroutine]
|
|
[:vm :lit :next :lit :interactive-eval-checkpoint :redefine]
|
|
vmcode
|
|
[:vm :ret])
|
|
(self:override-deferred-parent eval-prg :interactive-eval-checkpoint :code-to-eval)
|
|
(eval-prg:assemble)
|
|
eval-prg)
|
|
|
|
(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.TOPH :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 :< ; a b -- f
|
|
[:block
|
|
[:lda vm.ST1H :x]
|
|
[:cmp vm.TOPH :x]
|
|
[:bcc :islower]
|
|
[:lda vm.ST1 :x]
|
|
[:cmp vm.TOP :x]
|
|
[:bcc :islower]
|
|
[:lda 0] (vm:drop) [:sta vm.TOP :x] [:sta vm.TOPH :x] (vm:ret)
|
|
:islower
|
|
[:lda 0xff] (vm:drop) [:sta vm.TOP :x] [:sta vm.TOPH :x]])
|
|
(vm:word :<= :2dup :< :>rot := :|)
|
|
(vm:word :>= :< :not)
|
|
(vm:word :> :<= :not)
|
|
|
|
(vm:def :& ; a b -- c
|
|
[:lda vm.TOP :x] [:and vm.ST1 :x] [:sta vm.ST1 :x]
|
|
[:lda vm.TOPH :x] [:and vm.ST1H :x] [:sta vm.ST1H :x]
|
|
(vm:drop))
|
|
|
|
(vm:def :| ; a b -- c
|
|
[:lda vm.TOP :x] [:ora vm.ST1 :x] [:sta vm.ST1 :x]
|
|
[:lda vm.TOPH :x] [:ora vm.ST1H :x] [:sta vm.ST1H :x]
|
|
(vm:drop))
|
|
|
|
(vm:def :shl4 ; n -- n
|
|
[:asl vm.TOP :x] [:rol vm.TOPH :x]
|
|
[:asl vm.TOP :x] [:rol vm.TOPH :x]
|
|
[:asl vm.TOP :x] [:rol vm.TOPH :x]
|
|
[:asl vm.TOP :x] [:rol vm.TOPH :x])
|
|
vm)
|
|
|
|
{:new mk-vm}
|