diff --git a/UdpDebug.dsk b/UdpDebug.dsk index a7fac3e..3942ba0 100644 Binary files a/UdpDebug.dsk and b/UdpDebug.dsk differ diff --git a/asm/asm.fnl b/asm/asm.fnl index 894c0c2..0cf8450 100644 --- a/asm/asm.fnl +++ b/asm/asm.fnl @@ -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))) diff --git a/lib/util.fnl b/lib/util.fnl index 0173d4c..9330292 100644 --- a/lib/util.fnl +++ b/lib/util.fnl @@ -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} diff --git a/link/udpdebug.fnl b/link/udpdebug.fnl index c9ea367..d47de9f 100644 --- a/link/udpdebug.fnl +++ b/link/udpdebug.fnl @@ -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))) } diff --git a/neutgs/init.fnl b/neutgs/init.fnl index be8bdf1..ecb8a38 100644 --- a/neutgs/init.fnl +++ b/neutgs/init.fnl @@ -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) diff --git a/ssc/iigs/bootstub.fnl b/ssc/iigs/bootstub.fnl index e4ba376..7503506 100644 --- a/ssc/iigs/bootstub.fnl +++ b/ssc/iigs/bootstub.fnl @@ -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))) diff --git a/ssc/iigs/graphics.fnl b/ssc/iigs/graphics.fnl index fd400c0..d3f129c 100644 --- a/ssc/iigs/graphics.fnl +++ b/ssc/iigs/graphics.fnl @@ -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 (.. "")) - (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 (.. "")) + (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) diff --git a/ssc/iigs/u2-debug.fnl b/ssc/iigs/u2-debug.fnl index 77c913d..1d38f19 100644 --- a/ssc/iigs/u2-debug.fnl +++ b/ssc/iigs/u2-debug.fnl @@ -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) diff --git a/ssc/init.fnl b/ssc/init.fnl index dea214e..0d2e982 100644 --- a/ssc/init.fnl +++ b/ssc/init.fnl @@ -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 (.. "") + 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)] diff --git a/ssc/notes.txt b/ssc/notes.txt index 8802bf4..fe81799 100644 --- a/ssc/notes.txt +++ b/ssc/notes.txt @@ -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