honeylisp/vm.fnl

338 lines
7.6 KiB
Fennel

(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}