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

* Capture callsite details

Browse source 
* refactor "jump" command into "eval"
* Add debug server task to program
* Allow compiling overlay programs that assume the existing program is already in memory
* Add "forever" form to generate optimized infinite loops
* Handle client changing its udp port
This commit is contained in:
Jeremy Penner 2021-10-03 11:44:45 -04:00
parent 2df2abe543
commit 4d0beb0dbe
10 changed files with 120 additions and 71 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

BIN
UdpDebug.dsk
View file

Binary file not shown.

3
asm/asm.fnl
View file

@ -92,6 +92,7 @@
nil)
(fn dat-parser.align [pad] {:type :pad :align (. pad 2)})
(fn dat-parser.meta [[_ f]] {:type :meta :bytes "" :size 0 : f})
(fn dat-parser.hot-preserve [[_ label & dats] block]
(let [preserve-block (new-block)]
(tset block.preserved label preserve-block)
@ -107,6 +108,7 @@
:raw {}
:block {}
:pad {}
:meta {}
})
(fn describe-pdat [pdat]
@ -142,6 +144,7 @@
(int16-to-bytes (env:lookup-addr ref.target)))
(fn pdat-processor.pad.bytes [pad] (string.rep "\0" pad.size))
(fn pdat-processor.meta.generate [{: f : addr} env] (f addr env))
(fn pdat-processor.block.symbols [block]
(lume.concat (lume.keys block.symbols) (lume.keys block.globals)))

11
lib/util.fnl
View file

@ -23,11 +23,14 @@
(fn bytes-to-uint8 [b ?offset]
(string.byte b (+ 1 (or ?offset 0)) (+ 1 (or ?offset 0))))
(fn bytes-to-uint16 [b ?offset]
(local (lo hi) (string.byte b (+ 1 (or ?offset 0)) (+ 2 (or ?offset 0))))
(local (lo hi) (string.byte b (+ 1 (or ?offset 0)) (+ 2 (or ?offset 0))))
(bit.bor lo (bit.lshift hi 8)))
(fn bytes-to-uint24 [b ?offset]
(local (lo mid hi) (string.byte b (+ 1 (or ?offset 0)) (+ 3 (or ?offset 0))))
(bit.bor lo (bit.lshift mid 8) (bit.lshift hi 16)))
(fn bytes-to-uint32 [b ?offset]
(local [lo hi] [(bytes-to-uint16 b ?offset) (bytes-to-uint16 b (+ 2 (or ?offset 0)))])
(bit.bor lo (bit.lshift hi 16)))
(fn splice [bytes offset str]
(.. (bytes:sub 1 offset)
@ -130,8 +133,10 @@
(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 : condlist
(fn prototype [base] (setmetatable {} {:__index base}))
{: int8-to-bytes : int16-to-bytes : int24-to-bytes : int32-to-bytes : bytes-to-uint8 : bytes-to-uint16 : bytes-to-uint24 : bytes-to-uint32
: splice : lo : hi : loword : hiword : condlist : prototype
: reload : hotswap : swappable :require swappable-require : hot-table : nested-tset : pairoff : countiter
: readjson : writejson : file-exists : waitfor : in-coro : multival}

30
link/udpdebug.fnl
View file

@ -1,6 +1,8 @@
(local core (require :core))
(local socket (require :socket))
(local {: int16-to-bytes : int32-to-bytes : lo : in-coro} (require :lib.util))
(local {: int16-to-bytes : int32-to-bytes : bytes-to-uint16 : bytes-to-uint32 : lo : in-coro} (require :lib.util))
(local Ssc (require :ssc))
(import-macros {:sss ! : compile} :ssc.macros)
(local config {
:host "172.24.1.6"
@ -10,9 +12,10 @@
{:cmd {
:write 0
:read 1
:jmp 2
:eval 2
:pause 3
:ping 4
:read-dp 5
}
:response {
:ack 0
@ -36,7 +39,9 @@
(when self.connection
(self.connection:close)
(set self.connection nil)
(set self.pending {})))
(set self.pending {})
(set self.queue [])
(set self.waiting false)))
:next-msgid
(fn [self]
(set self.msgid (lo (+ self.msgid 1)))
@ -69,7 +74,19 @@
(table.remove self.queue 1)
(f))))))
:enqueue (fn [self f] (table.insert self.queue f))
:jump (fn [self addr] (self:send self.cmd.jmp (int32-to-bytes addr)))
:eval (fn [self c {: parent : org : ignore-result}]
(let [parent (or parent (require :ssc.iigs.u2-debug))
ssc (Ssc {: parent})
org (or org (parent.prg:lookup-addr :u2-debug-buffer))]
(compile ssc
(org [org])
(fn do-the-thing () [c]))
(ssc:assemble)
(if (not ignore-result)
(let [(_ data) (self:coro-send self.cmd.eval (. ssc.prg.org-to-block org :bytes))]
{:word (bytes-to-uint16 data) :long (bytes-to-uint32 data 2)})
(self:send self.cmd.eval (. ssc.prg.org-to-block org :bytes)))))
:jump (fn [self addr] (self:eval (! (asm (jsl [(tostring addr)]))) {:ignore-result true}))
:coro-send
(fn [self cmd ?data]
(let [coro (coroutine.running)]
@ -84,11 +101,14 @@
(let [(cmd data) (self:coro-send self.cmd.read (.. (int32-to-bytes addr)
(int16-to-bytes len)))] data)))
:handle-ack (fn [self cmd] (assert (= cmd self.response.ack)))
:write
(fn [self addr data]
(if (> (length data) 1450) (do (self:write addr (data:sub 1 1400)) (self:write (+ addr 1400) (data:sub 1401)))
(self:send self.cmd.write (.. (int32-to-bytes addr)
(int16-to-bytes (length data))
data) #nil)))
data) self.handle-ack)))
:pause (fn [self] (self:send self.cmd.write (int16-to-bytes 0xffff) self.handle-ack))
:resume (fn [self] (self:send self.cmd.write (int16-to-bytes 0) self.handle-ack))
:launch (fn [self prg] (self:jump (prg:lookup-addr prg.start-symbol)))
}

17
neutgs/init.fnl
View file

@ -1,9 +1,11 @@
(local Ssc (require :ssc))
(local files (require :game.files))
(local {: pal} (require :editor.tiledraw.iigs))
(local u2-debug (require :ssc.iigs.u2-debug))
(local link (require :link))
(import-macros {:sss ! : compile} :ssc.macros)
(local ssc (Ssc))
(local ssc (Ssc {:parent u2-debug}))
(compile ssc
(require ssc.iigs.bootstub)
(require ssc.iigs.toolbox)
@ -86,7 +88,7 @@
(if (= x 20)
(do (set! x 0)
(set! y (+ y 1))
(set! screen (+ screen [(+ 8 (* 160 15))])))
(set! screen (+ screen [(+ 8 (* 1 60 15))])))
(set! screen (+ screen 8)))))
(let (screen 0x2000 y 0)
(while (< y 200)
@ -96,18 +98,21 @@
(fn draw-test-tiles-forever ()
(let (i 0)
(while true
(forever
(draw-test-tiles i)
(yield)
(set! i (+ i 1)))))
(fn main ()
(fn debug-task () (forever [(if (= link.name :udpdebug) [:u2-debug-server-poll] [:do])] (yield)))
(far-fn main ()
(new-task (ref debug-task))
(LoadTools (far-ref toolsets))
(set! userID (MMStartUp))
(IMStartUp)
(TextStartUp)
(QDStartUp 0x2100 0 0 userID)
(EMStartUp 0x2000 0 0 320 0 200 userID)
(QDStartUp 0x3100 0 0 userID)
(EMStartUp 0x3000 0 0 320 0 200 userID)
(GrafOn)
(ClearScreen 0)
(let (screen 0x12000) (while (< screen 0x1a000)

8
ssc/iigs/bootstub.fnl
View file

@ -23,8 +23,7 @@
(global long BootHandle-e1)
(global long BootHandle-06)
(fn boot ()
(asm (phk) (plb)) ; data currently lives in program bank
(far-fn boot ()
(save-dp-sp 0x0800)
(set-task-base 0x0800) ; space for 8 tasks
(save-6502-stack)
@ -43,7 +42,7 @@
(set! BootHandle-e0 (NewHandle 0x4000 BootUserID 0xb017 0xe02000))
(set! BootHandle-e1 (NewHandle 0x8000 BootUserID 0xb017 0xe12000))
(asm (jsr [(or $2 :main)]))
(asm (jsl [(or $2 :main)]))
(DisposeHandle BootHandle-e1)
(DisposeHandle BootHandle-e0)
@ -55,6 +54,5 @@
(MTShutDown)
(restore-6502-stack)
(restore-dp-sp)
(asm (rtl))))
(restore-dp-sp)))

15
ssc/iigs/graphics.fnl
View file

@ -117,14 +117,13 @@
(macrobarrier drawfn)
(form drawfn [(lambda [ssc name ...]
(assert (not (ssc:defining?)) "drawfn must be defined at top level")
(set ssc.locals nil) ; locals cannot be used
(local fname (.. "<drawfn " name ">"))
(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 fname])])
(ssc:expr-poly [:define name [:ref fname]])
(ssc.org:append fname asm))])
(let [expr (lume.concat [:do ...] [[:asm [:jmp :draw-object-finished]]])]
(ssc:define-fn name nil #(do
(local fname (.. "<drawfn " name ">"))
(local asm (ssc:expr-poly expr))
(ssc:expr-poly [:form name (fn [ssc] (assert (= ssc.locals nil) (.. name " must be called from a drawfn")) [:jmp fname])])
(ssc:expr-poly [:define name [:ref fname]])
(ssc.org:append fname asm)))))])
(drawfn pei-slam-tile
(asm (tsc) (tcd) (adc 7) (tcs)

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

@ -33,18 +33,18 @@
(require ssc.iigs.uthernet2)
(global word u2-debug-server-connected 0)
(fn u2-init-debug-server ()
(out "Starting server")
(u2-reset)
(u2-udp-server-start 6502)
(set! u2-debug-server-connected 0))
(u2-udp-server-start 6502))
(buffer u2-debug-buffer 1500)
(predef-fn u2-debug-server-poll () void far)
(global word u2-debug-server-paused false)
(fn u2-debug-server-cmd-write (msgid)
(set! u2-debug-server-paused true)
(let (addr (long-at (ref u2-debug-buffer))
size (word-at (+ (ref u2-debug-buffer) 4)))
(memcpy (+ (far-ref u2-debug-buffer) 6) addr size)
@ -62,11 +62,19 @@
(u2-write-farbuf addr size)
(u2-tx-complete)))
(fn u2-debug-server-cmd-jmp () (asm (jmp ((u2-debug-buffer)))))
(fn u2-debug-server-cmd-exec (msgid)
(let (val (asm (jsr u2-debug-buffer))
longval (asm-long))
(u2-tx-begin 8)
(u2-write msgid)
(u2-write [response.data])
(u2-write-word val)
(u2-write-word (loword longval))
(u2-write-word (hiword longval))
(u2-tx-complete)))
(global word u2-debug-server-paused 0)
(fn u2-debug-server-cmd-pause (msgid)
(set! u2-debug-server-paused (not u2-debug-server-paused))
(set! u2-debug-server-paused (word-at (ref u2-debug-buffer)))
(u2-tx-begin 3)
(u2-write msgid)
(u2-write [response.ack])
@ -84,7 +92,7 @@
(fn u2-debug-server-cmd (msgid cmd)
(if (= cmd [cmd.write]) (u2-debug-server-cmd-write msgid)
(= cmd [cmd.read]) (u2-debug-server-cmd-read msgid)
(= cmd [cmd.jmp]) (u2-debug-server-cmd-jmp)
(= cmd [cmd.eval]) (u2-debug-server-cmd-exec msgid)
(= cmd [cmd.pause]) (u2-debug-server-cmd-pause msgid)
(= cmd [cmd.ping]) (u2-debug-server-cmd-ping msgid)))
@ -96,16 +104,14 @@
(printnum msgid) (printnum cmd) (out "Got message!")
(u2-read-buf (ref u2-debug-buffer) (- size 2))
(u2-rx-complete)
(when (not u2-debug-server-connected)
(u2-set-tx-dest u2-udp-recv-ip u2-udp-recv-port)
(set! u2-debug-server-connected true))
(u2-set-tx-dest u2-udp-recv-ip u2-udp-recv-port)
(u2-debug-server-cmd msgid cmd)))))
(fn debug-server-loop ()
(TextStartUp)
(IMStartUp)
(u2-init-debug-server)
(while true (u2-debug-server-poll)))
(forever (u2-debug-server-poll)))
)
(let [Prodos (require :asm.prodos)

75
ssc/init.fnl
View file

@ -36,26 +36,27 @@
(local Ssc (Object:extend))
(local Prg (require :asm.asm))
(local util (require :lib.util))
(local {: loword : hiword : pairoff : countiter : condlist} util)
(local {: loword : hiword : pairoff : countiter : condlist : prototype} util)
(fn Ssc.new [self ?opts]
(local opts (or ?opts {}))
(set self.prg (or opts.prg (Prg.new nil :65816)))
(set self.forms (lume.clone (or opts.forms self.__index.forms)))
(set self.functions {})
(set self.prg (Prg.new (or opts.prg (?. opts.parent :prg)) :65816))
(set self.forms (prototype (or opts.forms (?. opts.parent :forms) self.__index.forms)))
(set self.functions (prototype (or (?. opts.parent :functions) {})))
(set self.locals [])
(set self.modules {})
(set self.globals {})
(set self.constants {:true 0xffff true 0xffff :false 0 false 0})
(set self.macros (lume.clone (or opts.macros self.__index.macros)))
(set self.macrobarriers {:fn true :far-fn true :do true})
(set self.setters {})
(set self.dp-vars 0)
(set self.gensym-count 0)
(set self.LONG_LO (self:alloc-dp-var))
(set self.LONG_HI (self:alloc-dp-var))
(set self.ADDR_LO (self:alloc-dp-var))
(set self.ADDR_HI (self:alloc-dp-var)))
(set self.addr-to-callsite {})
(set self.modules (prototype (or (?. opts.parent :modules) {})))
(set self.globals (prototype (or (?. opts.parent :globals) {})))
(set self.constants (prototype (or (?. opts.parent :constants) {:true 0xffff true 0xffff :false 0 false 0})))
(set self.macros (prototype (or opts.macros (?. opts.parent :macros) self.__index.macros)))
(set self.macrobarriers (prototype (or (?. opts.parent :macrobarriers) {:fn true :far-fn true :do true})))
(set self.setters (prototype (or (?. opts.parent :setters) {})))
(set self.dp-vars (or (?. opts.parent :dp-vars) 0))
(set self.gensym-count (or (?. opts.parent :gensym-count) 0))
(set self.LONG_LO (or (?. opts.parent :LONG_LO) (self:alloc-dp-var)))
(set self.LONG_HI (or (?. opts.parent :LONG_HI) (self:alloc-dp-var)))
(set self.ADDR_LO (or (?. opts.parent :ADDR_LO) (self:alloc-dp-var)))
(set self.ADDR_HI (or (?. opts.parent :ADDR_HI) (self:alloc-dp-var))))
(fn Ssc.alloc-dp-var [self]
(let [addr (.. :d self.dp-vars)]
@ -103,7 +104,21 @@
(fn Ssc.was-dropped [self localcount]
(set self.locals (lume.slice self.locals 1 (- (length self.locals) localcount))))
(fn Ssc.defining? [self] (or (= self.locals nil) (> (length self.locals) 0)))
(fn Ssc.define-fn [self name locals f]
(assert (not (self:defining?)) "Can't nest function definitions")
(set self.defining-fn name)
(set self.locals (when locals (lume.clone locals)))
(set self.callsites {})
(let [result (f)]
(set self.defining-fn nil)
(set self.callsites {})
(assert (or (and (= locals nil) (= self.locals nil))
(= (length self.locals) (length locals)))
(.. "Left locals on stack?? Expected " (fv locals) " got " (fv self.locals)))
(set self.locals [])
result))
(fn Ssc.defining? [self] (not= self.defining-fn nil))
; 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
@ -191,15 +206,11 @@
(fn Ssc.cmp-to-bool [self op ...] (self:expr-poly [:if [op ...] true false]))
(fn Ssc.compile-function-generic [self name args body post-body returnaddr-type call-instruction]
(assert (not (self:defining?)) "Can't nest function definitions")
(local arglocals (self:parse-parameters args))
(set self.locals (lume.concat arglocals [{:type returnaddr-type :comment :returnaddr}]))
(local (c-function etype) (self:expr-poly body))
(self.org:append name c-function (table.unpack post-body))
(assert (= (length self.locals) (+ (length args) 1))
(.. "Left locals on stack?? Expected " (tostring (+ (length args) 1)) " got " (tostring (length self.locals))))
(set self.locals [])
{:arity (length args) :args arglocals :org self.org :type etype : name : call-instruction})
(let [arglocals (self:parse-parameters args)]
(self:define-fn name (lume.concat arglocals [{:type returnaddr-type :comment :returnaddr}])
#(let [(c-function etype) (self:expr-poly body)]
(self.org:append name c-function (table.unpack post-body))
{:arity (length args) :args arglocals :org self.org :type etype : name : call-instruction}))))
(fn Ssc.compile-function [self name args ...] (self:compile-function-generic name args [:do ...] [[:rts]] :word :jsr))
(fn Ssc.compile-far-function [self name args ...] (self:compile-function-generic name args [:do [:asm [:phb] [:phk] [:plb]] ...] [[:plb] [:rtl]] :long :jsl))
@ -291,6 +302,7 @@
(let [block [:block :-loop-top- (self:gen-condition test :-enter-loop- :-exit-loop-) :-enter-loop-]
c-body (self:expr-poly [:do ...])]
(values (lume.concat block [c-body [:brl :-loop-top-] :-exit-loop-]) :void)))
:forever (lambda [self ...] [:block :-loop-top- (self:expr-poly [:do ...]) [:brl :-loop-top-]])
:+ (lambda [self first ...]
(self:accumulation-op
(fn [etype opgen]
@ -456,8 +468,8 @@
(fn Ssc.parse-parameters [self params]
(icollect [_ param (ipairs params)] (match param
[:long pname] {:name pname :type :long}
pname {:name pname :type :word})))
[:long pname] {:name pname :type :long}
pname {:name pname :type :word})))
(fn Ssc.push-arguments [self paramdefs args]
(icollect [iarg arg (ipairs args)]
@ -467,8 +479,13 @@
(fn Ssc.compile-function-call [self f args]
(let [pre (self:push-arguments f.args args)
locals (lume.clone self.locals)
callid (or (. self.callsites f.name) 0)
_ (tset self.callsites f.name (+ callid 1))
callsite-sym (.. "<callsite " self.defining-fn " " f.name ":" callid ">")
capture-addr (fn [addr] (tset self.addr-to-callsite addr {: callsite-sym : locals}))
post (icollect [_ (countiter (length args))] (self:drop))]
(values (lume.concat [:block] pre [[f.call-instruction f.name]] post) f.type)))
(values (lume.concat [:block] pre [[f.call-instruction f.name] callsite-sym [:export callsite-sym] [:meta capture-addr]] post) f.type)))
(fn Ssc.enter-expr [self expr]
(let [m (getmetatable expr)]

4
ssc/notes.txt
View file

@ -1,7 +1,3 @@
full compilation to expr-opgen TODO:
- word! and long! are a mess right now
- I don't think word-at and long-at could use it
- Could custom forms compile to opgens?? What would this look like?
* see far-ref - it's really a constant, there's no reason to stuff the result into the temporary register just to push it onto the stack
* if you call expr-poly / expr-word / expr-long, then put it into the register