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

refactor set!, byte-at, word-at, long-at

Browse source
This commit is contained in:
Jeremy Penner 2021-09-26 00:34:48 -04:00
parent 683296b4e8
commit 5e46b908bd
7 changed files with 64 additions and 70 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

BIN
UdpDebug.dsk
View file

Binary file not shown.

4
lib/util.fnl
View file

@ -128,8 +128,10 @@
(let [i (if iprev (+ iprev step) min)]
(when (if (> step 0) (<= i max) (>= i max)) i)))))
(fn condlist [...] (let [l []] (lume.push l ...) l))
{: 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
: splice : lo : hi : loword : hiword : condlist
: reload : hotswap : swappable :require swappable-require : hot-table : nested-tset : pairoff : countiter
: readjson : writejson : file-exists : waitfor : in-coro : multival}

3
link/udpdebug.fnl
View file

@ -3,7 +3,7 @@
(local {: int16-to-bytes : int32-to-bytes : lo} (require :lib.util))
(local config {
:host "pi.local"
:host "rat.local"
:port 6502
})
@ -53,6 +53,7 @@
(let [msgid (string.byte (data:sub 1 1))
cmd (string.byte (data:sub 2 2))
pendingfn (. self.pending msgid)]
(print msgid cmd)
(when pendingfn
(tset self.pending msgid nil)
(pendingfn self cmd (data:sub 3))))))))

4
ssc/iigs/bootstub.fnl
View file

@ -3,14 +3,14 @@
#(compile $1
(start-symbol boot)
[(when (not= link.name :udpdebug) (! ;udpdebug boots into 16-bit mode
[(when (not= link.name :udpdebug) (! (do ;udpdebug boots into 16-bit mode
(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)

2
ssc/iigs/u2-debug.fnl
View file

@ -1,6 +1,8 @@
(import-macros {:sss ! : compile} :ssc.macros)
(local {: cmd : response} (require :link.udpdebug))
; sudo route add -net 172.24.1.0/24 gw 192.168.2.25
; -VEDRIVE
; CAT,S1
; BLOAD UDPDEBUG.SYSTEM, TSYS, A$2000

2
ssc/iigs/uthernet2.fnl
View file

@ -15,7 +15,7 @@
U2-ADDR-LO (reg 0xc086)
U2-DATA (reg 0xc087)]
#(compile $1
(fn u2-addr! (addr) (word! (ref [U2-ADDR-HI]) (byteswap addr)))
(form u2-addr! [#($1:expr-poly [:word! [:ref U2-ADDR-HI] [:byteswap $2]])])
(form u2-read [#($1:expr-poly [:byte-at [:ref U2-DATA]])])
(form u2-write [#($1:expr-poly [:byte! [:ref U2-DATA] $2])])
(fn u2-read-word ()

119
ssc/init.fnl
View file

@ -37,7 +37,7 @@
(local Ssc (Object:extend))
(local Prg (require :asm.asm))
(local util (require :lib.util))
(local {: loword : hiword : pairoff : countiter} util)
(local {: loword : hiword : pairoff : countiter : condlist} util)
(fn Ssc.new [self ?opts]
(local opts (or ?opts {}))
@ -208,6 +208,23 @@
[:block] (self:asm-localify inst)
_ inst)))
(fn string? [v] (= (type v) :string))
(fn xxxx-at [v] ; matches byte-at, word-at, long-at
(when (string? v)
(let [(i-at i-done) (v:find :-at)]
(when (and i-at (= i-done (length v))) (v:sub 1 (- i-at 1))))))
(fn Ssc.compile-read-at [self ref etype] ; opgen catches the trivial cases; we have to compile ref to get a pointer
(let [opgen (self:expr-opgen ref)
pre (when opgen.setup (opgen.setup))
load (if opgen.hi [:lda [[self.ADDR_LO]] :y] [:lda [self.ADDR_LO] :y])
load (if (= etype :byte) [:block [:rep 0x30] load [:sep 0x30] [:and 0xff]] load)]
(values (condlist :block pre (opgen.lo :lda) [:sta self.ADDR_LO]
(when opgen.hi [:block (opgen.hi :lda) [:sta self.ADDR_HI]])
[:ldy 0] load
(when (= etype :long) [:block [:sta self.LONG_LO] [:ldy 2] load [:sta self.LONG_HI]]))
(if (= etype :byte) :word etype))))
(set Ssc.forms
{:asm (fn [self ...] (if (self:defining?) (self:asm-localify [:block ...]) (self.org:append (table.unpack (self:asm-localify [...])))))
:asm-long (fn [self ...] (values [:block ...] :long))
@ -306,61 +323,42 @@
:byteswap (lambda [self word] [:block (self:expr-word word) [:xba]])
; TODO: maybe handle a few different addressing modes here? re-use if the value is already on the stack?
; TODO: automatically handle far-ref
:byte! (lambda [self ref value]
(let [(c-addr reftype) (self:expr-poly ref)]
(values (match reftype
:word [:block c-addr [:sta self.ADDR_LO] (self:expr-word value) [:ldy 0] [:sep 0x30] [:sta [self.ADDR_LO] :y] [:rep 0x30]]
:long [:block c-addr [:lda self.LONG_LO] [:sta self.ADDR_LO] [:lda self.LONG_HI] [:sta self.ADDR_HI]
(self:expr-word value) [:sep 0x30] [:sta [[self.ADDR_LO]]] [:rep 0x30]]
_ (error (.. "Unknown reference type " reftype)))
:void)))
:word! (lambda [self ref value]
(let [(c-addr reftype) (self:expr-poly ref)]
(values (match reftype
:word [:block c-addr [:sta self.ADDR_LO] (self:expr-word value) [:ldy 0] [:sta [self.ADDR_LO] :y]]
:long [:block c-addr [:lda self.LONG_LO] [:sta self.ADDR_LO] [:lda self.LONG_HI] [:sta self.ADDR_HI]
(self:expr-word value) [:sta [[self.ADDR_LO]]]]
_ (error (.. "Unknown reference type " reftype)))
:void)))
:long! (lambda [self ref value] [:block (self:push nil ref :word)
(self:expr-long value) [:ldy 0] [:lda self.LONG_LO] [:sta [1 :s] :y] [:iny] [:iny] [:lda self.LONG_HI] [:sta [1 :s] :y]
(self:drop)])
:byte! (lambda [self ref value] (self:expr-poly [:set! [:byte-at ref] value]))
:word! (lambda [self ref value] (self:expr-poly [:set! [:word-at ref] value]))
:long! (lambda [self ref value] (self:expr-poly [:set! [:long-at ref] value]))
:long (lambda [self value] (values [:block (self:expr-word value) [:sta self.LONG_LO] [:lda 0] [:sta self.LONG_HI]] :long))
:byte-at (lambda [self ref]
(local (c-ref etype) (self:expr-poly ref))
(if (= etype :word)
[:block (self:push nil ref :word) [:ldy 0] [:sep 0x30] [:lda [1 :s] :y] [:rep 0x30] [:and 0xff] (self:drop)]
(= etype :long)
[:block c-ref [:ldy 0] [:sep 0x30] [:lda [[self.LONG_LO]] :y] [:rep 0x30] [:and 0xff]]))
:word-at (lambda [self ref]
(local (c-ref etype) (self:expr-poly ref))
(if (= etype :word)
[:block (self:push nil ref :word) [:ldy 0] [:lda [1 :s] :y] (self:drop)]
(= etype :long)
[:block c-ref [:ldy 0] [:lda [[self.LONG_LO]] :y]]))
:long-at (lambda [self ref]
(local (c-ref etype) (self:expr-poly ref))
(if (= etype :word)
(values [:block (self:push nil ref :word) [:ldy 0] [:lda [1 :s] :y] [:sta self.LONG_LO] [:iny] [:iny] [:lda [1 :s] :y] [:sta self.LONG_HI] (self:drop)]
:long)
(= etype :long)
(values [:block c-ref [:ldy 0] [:lda [[self.LONG_LO]] :y] [:tax] [:iny] [:iny] [:lda [[self.LONG_LO]] :y] [:sta self.LONG_HI] [:stx self.LONG_LO]]
:long)))
:byte-at (lambda [self ref] (self:compile-read-at ref :byte))
:word-at (lambda [self ref] (self:compile-read-at ref :word))
:long-at (lambda [self ref] (self:copmile-read-at ref :long))
:set! (lambda [self lhs value]
(if (and (= (type lhs) :string) (. self.setters lhs))
(self:compile-function-call (. self.setters lhs) [value])
(let [{:lo val-lo :hi val-hi : setup} (assert (self:expr-opgen value) (.. (fv value) " did not produce a value"))
c-setup (when setup (setup))
{: lo : hi} (assert (self:opgen-lhs lhs) (.. (fv lhs) " not valid as a target of set!"))
c-lo [:flatten (val-lo :lda) (lo :sta)]
c-hi (when hi [:flatten (if val-hi (val-hi :lda) [:lda 0]) (hi :sta)])
block [:block]]
(lume.push block c-setup c-lo c-hi)
block)))
(self:opgen-lhs lhs)
(let [{:lo val-lo :hi val-hi : setup} (assert (self:expr-opgen value) (.. (fv value) " did not produce a value"))
c-setup (when setup (setup))
{: lo : hi} (self:opgen-lhs lhs)
c-lo [:flatten (val-lo :lda) (lo :sta)]
c-hi (when hi [:flatten (if val-hi (val-hi :lda) [:lda 0]) (hi :sta)])
block [:block]]
(lume.push block c-setup c-lo c-hi)
(values block :void))
(and (= (type lhs) :table) (xxxx-at (. lhs 1)))
(let [ropgen (self:push-opgen value)
pre1 (when ropgen.setup (ropgen.setup))
lopgen (self:expr-opgen (. lhs 2))
pre2 (when lopgen.setup (lopgen.setup))
etype (xxxx-at (. lhs 1))
store (if lopgen.hi [:sta [[self.ADDR_LO]] :y] [:sta [self.ADDR_LO] :y])
store (if (= etype :byte) [:block [:rep 0x30] store [:sep 0x30]] store)]
(values (condlist :block pre1 pre2 (lopgen.lo :lda) [:sta self.ADDR_LO]
(when lopgen.hi [:block (lopgen.hi :lda) [:sta self.ADDR_HI]])
(ropgen.lo :lda) [:ldy 0] store
(when (= etype :long) [:block (if ropgen.hi (ropgen.hi :lda) [:lda 0]) [:ldy 2] store])
(when ropgen.cleanup (ropgen.cleanup)))
:void))
(error (.. (fv lhs) " not valid as a target of set!"))))
})
(fn Ssc.local-offset [self name-or-index]
@ -396,7 +394,8 @@
{:lo #[$1 (self:local-offset loc) :s] :hi (when (= (self:local-type loc) :long) #[$1 (+ (self:local-offset loc) 2) :s])})
(fn Ssc.opgen-symbol [self name etype]
{:lo #[$1 name] :hi (when (= etype :long) #[:block [:ldy 2] [$1 name :y]])}) ; this is stupid - the assembler should be able to calculate addr + 2
(if (= etype :byte) {:lo #[:block [:sep 0x30] [$1 name] [:rep 0x30] (when (= $1 :lda) [:and 0xff])]}
{:lo #[$1 name] :hi (when (= etype :long) #[$1 {:abs #(+ ($1:lookup-addr name) 2)}])}))
(fn Ssc.opgen-global [self name] (self:opgen-symbol name (. self.globals name :type)))
@ -405,22 +404,12 @@
{:lo #[:block [:ldy 0] [$1 [(self:local-offset name) :s] :y]]
:hi (when (= etype :long) #[:block [:ldy 2] [$1 [(self:local-offset name) :s] :y]])}))
(fn Ssc.opgen-ref-global [self name etype]
(match (. self.globals name :type)
:word {:lo #[:block [:ldy 0] [$1 [name] :y]] :hi (when (= etype :long) #[:block [:ldy 2] [$1 [name] :y]])}
:long {:lo #[:block [:ldy 0] [$1 [[name]] :y]] :hi (when (= etype :long) #[:block [:ldy 2] [$1 [[name]] :y]])}))
(fn string? [v] (= (type v) :string))
(fn Ssc.opgen-lhs [self expr]
(match [(type expr) expr]
[:string _] (if (self:local-offset expr) (self:opgen-local expr)
(. self.globals expr) (self:opgen-global expr))
(where [_ [:word-at [:ref name]]] (string? name)) (self:opgen-symbol name :word)
(where [_ [:long-at [:ref name]]] (string? name)) (self:opgen-symbol name :long)
(where [_ [:word-at name]] (string? name)) (if (self:local-offset name) (self:opgen-ref-loc name :word)
(. self.globals name) (self:opgen-ref-global name :word))
(where [_ [:long-at name]] (string? name)) (if (self:local-offset name) (self:opgen-ref-loc name :long)
(. self.globals name) (self:opgen-ref-global name :long))))
(where [_ [type-at [:ref name]]] (string? name) (xxxx-at type-at)) (self:opgen-symbol name (xxxx-at type-at))
(where [_ [type-at name]] (string? name) (xxxx-at type-at) (self:local-offset name)) (self:opgen-ref-loc name (xxxx-at type-at))))
(fn Ssc.opgen [self expr]
(if (= (type expr) :number) (self:opgen-const expr)