* Capture callsite details
* 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:
parent
2df2abe543
commit
4d0beb0dbe
BIN
UdpDebug.dsk
BIN
UdpDebug.dsk
Binary file not shown.
|
@ -92,6 +92,7 @@
|
||||||
nil)
|
nil)
|
||||||
|
|
||||||
(fn dat-parser.align [pad] {:type :pad :align (. pad 2)})
|
(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]
|
(fn dat-parser.hot-preserve [[_ label & dats] block]
|
||||||
(let [preserve-block (new-block)]
|
(let [preserve-block (new-block)]
|
||||||
(tset block.preserved label preserve-block)
|
(tset block.preserved label preserve-block)
|
||||||
|
@ -107,6 +108,7 @@
|
||||||
:raw {}
|
:raw {}
|
||||||
:block {}
|
:block {}
|
||||||
:pad {}
|
:pad {}
|
||||||
|
:meta {}
|
||||||
})
|
})
|
||||||
|
|
||||||
(fn describe-pdat [pdat]
|
(fn describe-pdat [pdat]
|
||||||
|
@ -142,6 +144,7 @@
|
||||||
(int16-to-bytes (env:lookup-addr ref.target)))
|
(int16-to-bytes (env:lookup-addr ref.target)))
|
||||||
|
|
||||||
(fn pdat-processor.pad.bytes [pad] (string.rep "\0" pad.size))
|
(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]
|
(fn pdat-processor.block.symbols [block]
|
||||||
(lume.concat (lume.keys block.symbols) (lume.keys block.globals)))
|
(lume.concat (lume.keys block.symbols) (lume.keys block.globals)))
|
||||||
|
|
||||||
|
|
|
@ -28,6 +28,9 @@
|
||||||
(fn bytes-to-uint24 [b ?offset]
|
(fn bytes-to-uint24 [b ?offset]
|
||||||
(local (lo mid hi) (string.byte b (+ 1 (or ?offset 0)) (+ 3 (or ?offset 0))))
|
(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)))
|
(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]
|
(fn splice [bytes offset str]
|
||||||
(.. (bytes:sub 1 offset)
|
(.. (bytes:sub 1 offset)
|
||||||
|
@ -130,8 +133,10 @@
|
||||||
|
|
||||||
(fn condlist [...] (let [l []] (lume.push l ...) l))
|
(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
|
(fn prototype [base] (setmetatable {} {:__index base}))
|
||||||
: splice : lo : hi : loword : hiword : condlist
|
|
||||||
|
{: 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
|
: reload : hotswap : swappable :require swappable-require : hot-table : nested-tset : pairoff : countiter
|
||||||
: readjson : writejson : file-exists : waitfor : in-coro : multival}
|
: readjson : writejson : file-exists : waitfor : in-coro : multival}
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,8 @@
|
||||||
(local core (require :core))
|
(local core (require :core))
|
||||||
(local socket (require :socket))
|
(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 {
|
(local config {
|
||||||
:host "172.24.1.6"
|
:host "172.24.1.6"
|
||||||
|
@ -10,9 +12,10 @@
|
||||||
{:cmd {
|
{:cmd {
|
||||||
:write 0
|
:write 0
|
||||||
:read 1
|
:read 1
|
||||||
:jmp 2
|
:eval 2
|
||||||
:pause 3
|
:pause 3
|
||||||
:ping 4
|
:ping 4
|
||||||
|
:read-dp 5
|
||||||
}
|
}
|
||||||
:response {
|
:response {
|
||||||
:ack 0
|
:ack 0
|
||||||
|
@ -36,7 +39,9 @@
|
||||||
(when self.connection
|
(when self.connection
|
||||||
(self.connection:close)
|
(self.connection:close)
|
||||||
(set self.connection nil)
|
(set self.connection nil)
|
||||||
(set self.pending {})))
|
(set self.pending {})
|
||||||
|
(set self.queue [])
|
||||||
|
(set self.waiting false)))
|
||||||
:next-msgid
|
:next-msgid
|
||||||
(fn [self]
|
(fn [self]
|
||||||
(set self.msgid (lo (+ self.msgid 1)))
|
(set self.msgid (lo (+ self.msgid 1)))
|
||||||
|
@ -69,7 +74,19 @@
|
||||||
(table.remove self.queue 1)
|
(table.remove self.queue 1)
|
||||||
(f))))))
|
(f))))))
|
||||||
:enqueue (fn [self f] (table.insert self.queue 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
|
:coro-send
|
||||||
(fn [self cmd ?data]
|
(fn [self cmd ?data]
|
||||||
(let [coro (coroutine.running)]
|
(let [coro (coroutine.running)]
|
||||||
|
@ -84,11 +101,14 @@
|
||||||
|
|
||||||
(let [(cmd data) (self:coro-send self.cmd.read (.. (int32-to-bytes addr)
|
(let [(cmd data) (self:coro-send self.cmd.read (.. (int32-to-bytes addr)
|
||||||
(int16-to-bytes len)))] data)))
|
(int16-to-bytes len)))] data)))
|
||||||
|
:handle-ack (fn [self cmd] (assert (= cmd self.response.ack)))
|
||||||
:write
|
:write
|
||||||
(fn [self addr data]
|
(fn [self addr data]
|
||||||
(if (> (length data) 1450) (do (self:write addr (data:sub 1 1400)) (self:write (+ addr 1400) (data:sub 1401)))
|
(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)
|
(self:send self.cmd.write (.. (int32-to-bytes addr)
|
||||||
(int16-to-bytes (length data))
|
(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)))
|
:launch (fn [self prg] (self:jump (prg:lookup-addr prg.start-symbol)))
|
||||||
}
|
}
|
||||||
|
|
|
@ -1,9 +1,11 @@
|
||||||
(local Ssc (require :ssc))
|
(local Ssc (require :ssc))
|
||||||
(local files (require :game.files))
|
(local files (require :game.files))
|
||||||
(local {: pal} (require :editor.tiledraw.iigs))
|
(local {: pal} (require :editor.tiledraw.iigs))
|
||||||
|
(local u2-debug (require :ssc.iigs.u2-debug))
|
||||||
|
(local link (require :link))
|
||||||
(import-macros {:sss ! : compile} :ssc.macros)
|
(import-macros {:sss ! : compile} :ssc.macros)
|
||||||
|
|
||||||
(local ssc (Ssc))
|
(local ssc (Ssc {:parent u2-debug}))
|
||||||
(compile ssc
|
(compile ssc
|
||||||
(require ssc.iigs.bootstub)
|
(require ssc.iigs.bootstub)
|
||||||
(require ssc.iigs.toolbox)
|
(require ssc.iigs.toolbox)
|
||||||
|
@ -86,7 +88,7 @@
|
||||||
(if (= x 20)
|
(if (= x 20)
|
||||||
(do (set! x 0)
|
(do (set! x 0)
|
||||||
(set! y (+ y 1))
|
(set! y (+ y 1))
|
||||||
(set! screen (+ screen [(+ 8 (* 160 15))])))
|
(set! screen (+ screen [(+ 8 (* 1 60 15))])))
|
||||||
(set! screen (+ screen 8)))))
|
(set! screen (+ screen 8)))))
|
||||||
(let (screen 0x2000 y 0)
|
(let (screen 0x2000 y 0)
|
||||||
(while (< y 200)
|
(while (< y 200)
|
||||||
|
@ -96,18 +98,21 @@
|
||||||
|
|
||||||
(fn draw-test-tiles-forever ()
|
(fn draw-test-tiles-forever ()
|
||||||
(let (i 0)
|
(let (i 0)
|
||||||
(while true
|
(forever
|
||||||
(draw-test-tiles i)
|
(draw-test-tiles i)
|
||||||
(yield)
|
(yield)
|
||||||
(set! i (+ i 1)))))
|
(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))
|
(LoadTools (far-ref toolsets))
|
||||||
(set! userID (MMStartUp))
|
(set! userID (MMStartUp))
|
||||||
(IMStartUp)
|
(IMStartUp)
|
||||||
(TextStartUp)
|
(TextStartUp)
|
||||||
(QDStartUp 0x2100 0 0 userID)
|
(QDStartUp 0x3100 0 0 userID)
|
||||||
(EMStartUp 0x2000 0 0 320 0 200 userID)
|
(EMStartUp 0x3000 0 0 320 0 200 userID)
|
||||||
(GrafOn)
|
(GrafOn)
|
||||||
(ClearScreen 0)
|
(ClearScreen 0)
|
||||||
(let (screen 0x12000) (while (< screen 0x1a000)
|
(let (screen 0x12000) (while (< screen 0x1a000)
|
||||||
|
|
|
@ -23,8 +23,7 @@
|
||||||
(global long BootHandle-e1)
|
(global long BootHandle-e1)
|
||||||
(global long BootHandle-06)
|
(global long BootHandle-06)
|
||||||
|
|
||||||
(fn boot ()
|
(far-fn boot ()
|
||||||
(asm (phk) (plb)) ; data currently lives in program bank
|
|
||||||
(save-dp-sp 0x0800)
|
(save-dp-sp 0x0800)
|
||||||
(set-task-base 0x0800) ; space for 8 tasks
|
(set-task-base 0x0800) ; space for 8 tasks
|
||||||
(save-6502-stack)
|
(save-6502-stack)
|
||||||
|
@ -43,7 +42,7 @@
|
||||||
(set! BootHandle-e0 (NewHandle 0x4000 BootUserID 0xb017 0xe02000))
|
(set! BootHandle-e0 (NewHandle 0x4000 BootUserID 0xb017 0xe02000))
|
||||||
(set! BootHandle-e1 (NewHandle 0x8000 BootUserID 0xb017 0xe12000))
|
(set! BootHandle-e1 (NewHandle 0x8000 BootUserID 0xb017 0xe12000))
|
||||||
|
|
||||||
(asm (jsr [(or $2 :main)]))
|
(asm (jsl [(or $2 :main)]))
|
||||||
|
|
||||||
(DisposeHandle BootHandle-e1)
|
(DisposeHandle BootHandle-e1)
|
||||||
(DisposeHandle BootHandle-e0)
|
(DisposeHandle BootHandle-e0)
|
||||||
|
@ -55,6 +54,5 @@
|
||||||
(MTShutDown)
|
(MTShutDown)
|
||||||
|
|
||||||
(restore-6502-stack)
|
(restore-6502-stack)
|
||||||
(restore-dp-sp)
|
(restore-dp-sp)))
|
||||||
(asm (rtl))))
|
|
||||||
|
|
||||||
|
|
|
@ -117,14 +117,13 @@
|
||||||
|
|
||||||
(macrobarrier drawfn)
|
(macrobarrier drawfn)
|
||||||
(form drawfn [(lambda [ssc name ...]
|
(form drawfn [(lambda [ssc name ...]
|
||||||
(assert (not (ssc:defining?)) "drawfn must be defined at top level")
|
(let [expr (lume.concat [:do ...] [[:asm [:jmp :draw-object-finished]]])]
|
||||||
(set ssc.locals nil) ; locals cannot be used
|
(ssc:define-fn name nil #(do
|
||||||
(local fname (.. "<drawfn " name ">"))
|
(local fname (.. "<drawfn " name ">"))
|
||||||
(local asm (ssc:expr-poly (lume.concat [:do ...] [[:asm [:jmp :draw-object-finished]]])))
|
(local asm (ssc:expr-poly expr))
|
||||||
(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 [: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:expr-poly [:define name [:ref fname]])
|
||||||
(ssc.org:append fname asm))])
|
(ssc.org:append fname asm)))))])
|
||||||
|
|
||||||
(drawfn pei-slam-tile
|
(drawfn pei-slam-tile
|
||||||
(asm (tsc) (tcd) (adc 7) (tcs)
|
(asm (tsc) (tcd) (adc 7) (tcs)
|
||||||
|
|
|
@ -33,18 +33,18 @@
|
||||||
|
|
||||||
(require ssc.iigs.uthernet2)
|
(require ssc.iigs.uthernet2)
|
||||||
|
|
||||||
(global word u2-debug-server-connected 0)
|
|
||||||
(fn u2-init-debug-server ()
|
(fn u2-init-debug-server ()
|
||||||
(out "Starting server")
|
(out "Starting server")
|
||||||
(u2-reset)
|
(u2-reset)
|
||||||
(u2-udp-server-start 6502)
|
(u2-udp-server-start 6502))
|
||||||
(set! u2-debug-server-connected 0))
|
|
||||||
|
|
||||||
(buffer u2-debug-buffer 1500)
|
(buffer u2-debug-buffer 1500)
|
||||||
|
|
||||||
(predef-fn u2-debug-server-poll () void far)
|
(predef-fn u2-debug-server-poll () void far)
|
||||||
|
|
||||||
|
(global word u2-debug-server-paused false)
|
||||||
(fn u2-debug-server-cmd-write (msgid)
|
(fn u2-debug-server-cmd-write (msgid)
|
||||||
|
(set! u2-debug-server-paused true)
|
||||||
(let (addr (long-at (ref u2-debug-buffer))
|
(let (addr (long-at (ref u2-debug-buffer))
|
||||||
size (word-at (+ (ref u2-debug-buffer) 4)))
|
size (word-at (+ (ref u2-debug-buffer) 4)))
|
||||||
(memcpy (+ (far-ref u2-debug-buffer) 6) addr size)
|
(memcpy (+ (far-ref u2-debug-buffer) 6) addr size)
|
||||||
|
@ -62,11 +62,19 @@
|
||||||
(u2-write-farbuf addr size)
|
(u2-write-farbuf addr size)
|
||||||
(u2-tx-complete)))
|
(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)
|
(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-tx-begin 3)
|
||||||
(u2-write msgid)
|
(u2-write msgid)
|
||||||
(u2-write [response.ack])
|
(u2-write [response.ack])
|
||||||
|
@ -84,7 +92,7 @@
|
||||||
(fn u2-debug-server-cmd (msgid cmd)
|
(fn u2-debug-server-cmd (msgid cmd)
|
||||||
(if (= cmd [cmd.write]) (u2-debug-server-cmd-write msgid)
|
(if (= cmd [cmd.write]) (u2-debug-server-cmd-write msgid)
|
||||||
(= cmd [cmd.read]) (u2-debug-server-cmd-read 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.pause]) (u2-debug-server-cmd-pause msgid)
|
||||||
(= cmd [cmd.ping]) (u2-debug-server-cmd-ping msgid)))
|
(= cmd [cmd.ping]) (u2-debug-server-cmd-ping msgid)))
|
||||||
|
|
||||||
|
@ -96,16 +104,14 @@
|
||||||
(printnum msgid) (printnum cmd) (out "Got message!")
|
(printnum msgid) (printnum cmd) (out "Got message!")
|
||||||
(u2-read-buf (ref u2-debug-buffer) (- size 2))
|
(u2-read-buf (ref u2-debug-buffer) (- size 2))
|
||||||
(u2-rx-complete)
|
(u2-rx-complete)
|
||||||
(when (not u2-debug-server-connected)
|
|
||||||
(u2-set-tx-dest u2-udp-recv-ip u2-udp-recv-port)
|
(u2-set-tx-dest u2-udp-recv-ip u2-udp-recv-port)
|
||||||
(set! u2-debug-server-connected true))
|
|
||||||
(u2-debug-server-cmd msgid cmd)))))
|
(u2-debug-server-cmd msgid cmd)))))
|
||||||
|
|
||||||
(fn debug-server-loop ()
|
(fn debug-server-loop ()
|
||||||
(TextStartUp)
|
(TextStartUp)
|
||||||
(IMStartUp)
|
(IMStartUp)
|
||||||
(u2-init-debug-server)
|
(u2-init-debug-server)
|
||||||
(while true (u2-debug-server-poll)))
|
(forever (u2-debug-server-poll)))
|
||||||
)
|
)
|
||||||
|
|
||||||
(let [Prodos (require :asm.prodos)
|
(let [Prodos (require :asm.prodos)
|
||||||
|
|
69
ssc/init.fnl
69
ssc/init.fnl
|
@ -36,26 +36,27 @@
|
||||||
(local Ssc (Object:extend))
|
(local Ssc (Object:extend))
|
||||||
(local Prg (require :asm.asm))
|
(local Prg (require :asm.asm))
|
||||||
(local util (require :lib.util))
|
(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]
|
(fn Ssc.new [self ?opts]
|
||||||
(local opts (or ?opts {}))
|
(local opts (or ?opts {}))
|
||||||
(set self.prg (or opts.prg (Prg.new nil :65816)))
|
(set self.prg (Prg.new (or opts.prg (?. opts.parent :prg)) :65816))
|
||||||
(set self.forms (lume.clone (or opts.forms self.__index.forms)))
|
(set self.forms (prototype (or opts.forms (?. opts.parent :forms) self.__index.forms)))
|
||||||
(set self.functions {})
|
(set self.functions (prototype (or (?. opts.parent :functions) {})))
|
||||||
(set self.locals [])
|
(set self.locals [])
|
||||||
(set self.modules {})
|
(set self.addr-to-callsite {})
|
||||||
(set self.globals {})
|
(set self.modules (prototype (or (?. opts.parent :modules) {})))
|
||||||
(set self.constants {:true 0xffff true 0xffff :false 0 false 0})
|
(set self.globals (prototype (or (?. opts.parent :globals) {})))
|
||||||
(set self.macros (lume.clone (or opts.macros self.__index.macros)))
|
(set self.constants (prototype (or (?. opts.parent :constants) {:true 0xffff true 0xffff :false 0 false 0})))
|
||||||
(set self.macrobarriers {:fn true :far-fn true :do true})
|
(set self.macros (prototype (or opts.macros (?. opts.parent :macros) self.__index.macros)))
|
||||||
(set self.setters {})
|
(set self.macrobarriers (prototype (or (?. opts.parent :macrobarriers) {:fn true :far-fn true :do true})))
|
||||||
(set self.dp-vars 0)
|
(set self.setters (prototype (or (?. opts.parent :setters) {})))
|
||||||
(set self.gensym-count 0)
|
(set self.dp-vars (or (?. opts.parent :dp-vars) 0))
|
||||||
(set self.LONG_LO (self:alloc-dp-var))
|
(set self.gensym-count (or (?. opts.parent :gensym-count) 0))
|
||||||
(set self.LONG_HI (self:alloc-dp-var))
|
(set self.LONG_LO (or (?. opts.parent :LONG_LO) (self:alloc-dp-var)))
|
||||||
(set self.ADDR_LO (self:alloc-dp-var))
|
(set self.LONG_HI (or (?. opts.parent :LONG_HI) (self:alloc-dp-var)))
|
||||||
(set self.ADDR_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]
|
(fn Ssc.alloc-dp-var [self]
|
||||||
(let [addr (.. :d self.dp-vars)]
|
(let [addr (.. :d self.dp-vars)]
|
||||||
|
@ -103,7 +104,21 @@
|
||||||
(fn Ssc.was-dropped [self localcount]
|
(fn Ssc.was-dropped [self localcount]
|
||||||
(set self.locals (lume.slice self.locals 1 (- (length self.locals) 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
|
; 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
|
; 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.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]
|
(fn Ssc.compile-function-generic [self name args body post-body returnaddr-type call-instruction]
|
||||||
(assert (not (self:defining?)) "Can't nest function definitions")
|
(let [arglocals (self:parse-parameters args)]
|
||||||
(local arglocals (self:parse-parameters args))
|
(self:define-fn name (lume.concat arglocals [{:type returnaddr-type :comment :returnaddr}])
|
||||||
(set self.locals (lume.concat arglocals [{:type returnaddr-type :comment :returnaddr}]))
|
#(let [(c-function etype) (self:expr-poly body)]
|
||||||
(local (c-function etype) (self:expr-poly body))
|
|
||||||
(self.org:append name c-function (table.unpack post-body))
|
(self.org:append name c-function (table.unpack post-body))
|
||||||
(assert (= (length self.locals) (+ (length args) 1))
|
{:arity (length args) :args arglocals :org self.org :type etype : name : call-instruction}))))
|
||||||
(.. "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})
|
|
||||||
|
|
||||||
(fn Ssc.compile-function [self name args ...] (self:compile-function-generic name args [:do ...] [[:rts]] :word :jsr))
|
(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))
|
(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-]
|
(let [block [:block :-loop-top- (self:gen-condition test :-enter-loop- :-exit-loop-) :-enter-loop-]
|
||||||
c-body (self:expr-poly [:do ...])]
|
c-body (self:expr-poly [:do ...])]
|
||||||
(values (lume.concat block [c-body [:brl :-loop-top-] :-exit-loop-]) :void)))
|
(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 ...]
|
:+ (lambda [self first ...]
|
||||||
(self:accumulation-op
|
(self:accumulation-op
|
||||||
(fn [etype opgen]
|
(fn [etype opgen]
|
||||||
|
@ -467,8 +479,13 @@
|
||||||
|
|
||||||
(fn Ssc.compile-function-call [self f args]
|
(fn Ssc.compile-function-call [self f args]
|
||||||
(let [pre (self:push-arguments f.args 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))]
|
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]
|
(fn Ssc.enter-expr [self expr]
|
||||||
(let [m (getmetatable expr)]
|
(let [m (getmetatable expr)]
|
||||||
|
|
|
@ -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?
|
- 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
|
* 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
|
* if you call expr-poly / expr-word / expr-long, then put it into the register
|
||||||
|
|
Loading…
Reference in a new issue