Hotswap works in MAME (once)!
This commit is contained in:
parent
4d0beb0dbe
commit
e11241eb10
|
@ -251,15 +251,16 @@
|
||||||
(set self.dbgfile nil))
|
(set self.dbgfile nil))
|
||||||
self)
|
self)
|
||||||
:read-hotswap
|
:read-hotswap
|
||||||
(fn [self machine]
|
(fn [self machine prg-new]
|
||||||
(let [addr-to-label {}
|
(let [addr-to-label {}
|
||||||
addr-to-size {}]
|
addr-to-size {}]
|
||||||
(each [_ block (pairs self.org-to-block)]
|
(each [_ block (pairs self.org-to-block)]
|
||||||
(each [label pdat (pairs block.preserved)]
|
(each [label pdat (pairs block.preserved)]
|
||||||
(tset addr-to-label pdat.addr label)
|
(tset addr-to-label pdat.addr label)
|
||||||
(tset addr-to-size pdat.addr pdat.size)))
|
(tset addr-to-size pdat.addr pdat.size)))
|
||||||
(collect [addr bytes (pairs (machine:read-batch addr-to-size))]
|
(lume.merge (collect [addr bytes (pairs (machine:read-batch addr-to-size))]
|
||||||
(values (. addr-to-label addr) bytes))))
|
(values (. addr-to-label addr) bytes))
|
||||||
|
(if (?. self.source :read-hotswap) (self.source:read-hotswap machine prg-new) {}))))
|
||||||
:write-hotswap
|
:write-hotswap
|
||||||
(fn [self machine hotswap]
|
(fn [self machine hotswap]
|
||||||
(machine:write-batch
|
(machine:write-batch
|
||||||
|
|
|
@ -174,7 +174,7 @@
|
||||||
(self:set-bp addr
|
(self:set-bp addr
|
||||||
#(util.in-coro (fn []
|
#(util.in-coro (fn []
|
||||||
(self:clear-bp addr)
|
(self:clear-bp addr)
|
||||||
(local hotswap (prg-old:read-hotswap self))
|
(local hotswap (prg-old:read-hotswap self prg-new))
|
||||||
(prg-new:upload self)
|
(prg-new:upload self)
|
||||||
(prg-new:write-hotswap self hotswap)
|
(prg-new:write-hotswap self hotswap)
|
||||||
(self:jump (prg-new:lookup-addr :on-hotswap))
|
(self:jump (prg-new:lookup-addr :on-hotswap))
|
||||||
|
|
119
ssc/hotswap.fnl
Normal file
119
ssc/hotswap.fnl
Normal file
|
@ -0,0 +1,119 @@
|
||||||
|
; hotswap support
|
||||||
|
(local {: addr-parser} (require :asm.65816))
|
||||||
|
(local util (require :lib.util))
|
||||||
|
(local {: bytes-to-uint16 : bytes-to-uint24 : int16-to-bytes : int24-to-bytes} util)
|
||||||
|
|
||||||
|
; Hotswap theory:
|
||||||
|
; The common case is code moving around in memory; even if you are not changing the content of code that
|
||||||
|
; is currently executing, any changes to anything mean that pointers to that code will need to change.
|
||||||
|
; If you try not to store pointers in globals (when everything is statically allocated, you should explicitly
|
||||||
|
; name things, like in Forth) then the main place that persistent pointers to code exist is in call stacks -
|
||||||
|
; specifically, the values on the stack consumed by "rts" or "rtl". When hotswapping, we need to walk the
|
||||||
|
; callstack and A. find these values, and B. patch them to their new values. For this, we need to be able to
|
||||||
|
; map any address that might be returned to from the old program to the new program - we can easily do this
|
||||||
|
; by generating symbols for each callsite and setting up a reverse lookup table. We _also_ need to know the
|
||||||
|
; stack layout at the time of each call so that we can find the next link in the chain, and to verify that
|
||||||
|
; this hasn't changed (if the function has changed enough, then we can't modify it mid-execution).
|
||||||
|
|
||||||
|
(fn assert-local-matches [funcname loc-old loc-new]
|
||||||
|
(each [_ key (ipairs [:type :name :returnaddr])]
|
||||||
|
(assert (= (. loc-old key) (. loc-new key)) (.. "Stack mismatch when patching " funcname))))
|
||||||
|
|
||||||
|
(fn assert-locals-match [funcname locals-old locals-new]
|
||||||
|
(assert (= (length locals-old) (length locals-new)) (.. "Stack size mismatch when patching " funcname))
|
||||||
|
(each [iloc loc-old (ipairs locals-old)]
|
||||||
|
(assert-local-matches funcname loc-old (. locals-new iloc))))
|
||||||
|
|
||||||
|
(fn next-callsite-offset [locals]
|
||||||
|
(var offset 0)
|
||||||
|
(var start-counting false)
|
||||||
|
(each [_ loc (ipairs locals)]
|
||||||
|
(if start-counting (let [size (match loc.type :placeholder 0 :word 2 :long 4)] (set offset (+ offset size)))
|
||||||
|
loc.returnaddr (set start-counting true)))
|
||||||
|
offset)
|
||||||
|
|
||||||
|
(fn next-callsite-far? [locals]
|
||||||
|
(var far? false)
|
||||||
|
(each [_ loc (ipairs locals)]
|
||||||
|
(when (and loc.returnaddr (= loc.type :long))
|
||||||
|
(set far? true)))
|
||||||
|
far?)
|
||||||
|
|
||||||
|
(fn read-callsite-addr [stack bank far]
|
||||||
|
(if far (bytes-to-uint24 stack 1) ; lowest byte (top of stack) is preserved B register
|
||||||
|
(bit.bor (bytes-to-uint16 stack) (bit.lshift bank 16))))
|
||||||
|
|
||||||
|
(fn lookup-callsite [ssc addr]
|
||||||
|
(if (= addr (- (ssc.prg:lookup-addr :yield-forever) 1))
|
||||||
|
{:callsite-sym :yield-forever :locals [] :calling :yield-forever :funcname "<base task>"}
|
||||||
|
(. ssc.addr-to-callsite addr)))
|
||||||
|
|
||||||
|
(fn patch-stack [ssc-old ssc-new stack bank far]
|
||||||
|
(print (length stack) bank far)
|
||||||
|
(if (= (length stack) 0) stack
|
||||||
|
; top-of-stack should be a callsite; look it up
|
||||||
|
(let [callsite-addr (read-callsite-addr stack bank far)
|
||||||
|
{: callsite-sym : locals : funcname} (assert (lookup-callsite ssc-old callsite-addr)
|
||||||
|
(.. "Top of stack value " callsite-addr " is not a recognized callsite"))
|
||||||
|
new-addr (- (ssc-new.prg:lookup-addr callsite-sym) 1)
|
||||||
|
{:locals new-locals} (lookup-callsite ssc-new new-addr)
|
||||||
|
new-bank (bit.rshift new-addr 16)
|
||||||
|
_ (when (not far) (assert (= (bit.band callsite-addr 0xff0000) (bit.band new-addr 0xff0000))
|
||||||
|
(.. funcname " moved banks from " bank " to " new-bank)))
|
||||||
|
_ (print (.. "patching " callsite-sym " from " callsite-addr " to " new-addr))
|
||||||
|
_ (assert-locals-match funcname locals new-locals)
|
||||||
|
new-top (if far (.. (stack:sub 1 1) (int24-to-bytes new-addr))
|
||||||
|
(int16-to-bytes new-addr))
|
||||||
|
iaftertop (if far 5 3)
|
||||||
|
inextstack (+ iaftertop (next-callsite-offset locals))
|
||||||
|
_ (print (.. "locals " (fv locals) " offset " (next-callsite-offset locals)) inextstack)]
|
||||||
|
(.. new-top (stack:sub iaftertop (- inextstack 1))
|
||||||
|
(if (= funcname ssc-old.prg.start-symbol) (stack:sub inextstack) ; stop when we hit the boot-up function
|
||||||
|
(patch-stack ssc-old ssc-new (stack:sub inextstack) new-bank (next-callsite-far? locals)))))))
|
||||||
|
|
||||||
|
(fn split-equally [s size]
|
||||||
|
(values (fn [s iprev] (let [i (+ iprev 1)
|
||||||
|
istart (+ (* (- i 1) size) 1)
|
||||||
|
iend (* i size)]
|
||||||
|
(when (>= (length s) iend) (values i (s:sub istart iend)))))
|
||||||
|
s 0))
|
||||||
|
|
||||||
|
(fn read-stacks [link ssc]
|
||||||
|
(let [stack-bounds-addr (ssc.prg:lookup-addr :first-task)
|
||||||
|
stack-bounds-bytes (link:read stack-bounds-addr 4)
|
||||||
|
first-task (bytes-to-uint16 stack-bounds-bytes)
|
||||||
|
last-task (bytes-to-uint16 stack-bounds-bytes 2)
|
||||||
|
task-size 0x100
|
||||||
|
read-size (+ (- last-task first-task) task-size)
|
||||||
|
task-count (/ read-size task-size)
|
||||||
|
task-bytes (link:read first-task read-size)
|
||||||
|
sp-offset (addr-parser ssc.TASK-STACK)]
|
||||||
|
(icollect [_ task (split-equally task-bytes task-size)]
|
||||||
|
(let [sp-addr (bytes-to-uint16 task sp-offset)
|
||||||
|
istackstart (bit.band sp-addr 0xff)
|
||||||
|
stack (task:sub (+ istackstart 2))]
|
||||||
|
{:sp-addr (+ sp-addr 1) : stack}))))
|
||||||
|
|
||||||
|
(fn lookup-yield-bank [ssc] (bit.rshift (ssc.prg:lookup-addr :yield) 16))
|
||||||
|
(fn filter-nonyielding-stacks [ssc stacks]
|
||||||
|
(let [yield-bank (lookup-yield-bank ssc)]
|
||||||
|
(print "yield-bank" yield-bank)
|
||||||
|
(icollect [_ stack (ipairs stacks)]
|
||||||
|
(let [callsite-addr (read-callsite-addr stack.stack yield-bank false)
|
||||||
|
callsite (lookup-callsite ssc callsite-addr)
|
||||||
|
funcname (?. callsite :calling)]
|
||||||
|
(print "top callsite:" (string.format "%X" callsite-addr) (fv callsite))
|
||||||
|
(when (= funcname :yield) stack)))))
|
||||||
|
|
||||||
|
(fn hotswap-stacks [link ssc-old ssc-new]
|
||||||
|
(print "hotswappin time" link ssc-old ssc-new)
|
||||||
|
(let [stacks (read-stacks link ssc-old)
|
||||||
|
_ (print "read stacks" (fv stacks))
|
||||||
|
yielding-stacks (filter-nonyielding-stacks ssc-old stacks)]
|
||||||
|
(print "filtered stacks" (length stacks) (length yielding-stacks))
|
||||||
|
(collect [_ {: sp-addr : stack} (ipairs yielding-stacks)]
|
||||||
|
(let [(success new-stack) (pcall #(patch-stack ssc-old ssc-new stack (lookup-yield-bank ssc-old) false))]
|
||||||
|
(if success (do (print "patched" (stack:tohex) "to" (new-stack:tohex)) (values (tostring sp-addr) new-stack))
|
||||||
|
(error (.. new-stack ": stack at " (string.format "%X" sp-addr))))))))
|
||||||
|
|
||||||
|
{: hotswap-stacks}
|
|
@ -3,13 +3,16 @@
|
||||||
|
|
||||||
#(compile $1
|
#(compile $1
|
||||||
(start-symbol boot)
|
(start-symbol boot)
|
||||||
|
(predef-fn boot () void far)
|
||||||
|
(predef-fn [(or $2 :main)] () void far)
|
||||||
|
|
||||||
[(when (not= link.name :udpdebug) (! (do ;udpdebug boots into 16-bit mode
|
[(when (not= link.name :udpdebug) (! (do ;udpdebug boots into 16-bit mode
|
||||||
(start-symbol boot-8)
|
(start-symbol boot-8)
|
||||||
(org 0x1000)
|
(org 0x1000)
|
||||||
(fn boot-8 ()
|
(fn boot-8 ()
|
||||||
(asm (clc) (xce) (rep 0x30) ; disable emulation mode, 16-bit index registers
|
(asm (clc) (xce) (rep 0x30)) ; disable emulation mode, 16-bit index registers
|
||||||
(jsr boot)
|
(boot)
|
||||||
(sec) (xce))) ; re-enter emulation mode
|
(asm (sec) (xce))) ; re-enter emulation mode
|
||||||
)))]
|
)))]
|
||||||
|
|
||||||
(org 0x060000)
|
(org 0x060000)
|
||||||
|
@ -42,7 +45,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 (jsl [(or $2 :main)]))
|
( [(or $2 :main)] )
|
||||||
|
|
||||||
(DisposeHandle BootHandle-e1)
|
(DisposeHandle BootHandle-e1)
|
||||||
(DisposeHandle BootHandle-e0)
|
(DisposeHandle BootHandle-e0)
|
||||||
|
|
12
ssc/init.fnl
12
ssc/init.fnl
|
@ -207,7 +207,7 @@
|
||||||
|
|
||||||
(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]
|
||||||
(let [arglocals (self:parse-parameters args)]
|
(let [arglocals (self:parse-parameters args)]
|
||||||
(self:define-fn name (lume.concat arglocals [{:type returnaddr-type :comment :returnaddr}])
|
(self:define-fn name (lume.concat arglocals [{:type returnaddr-type :returnaddr true}])
|
||||||
#(let [(c-function etype) (self:expr-poly body)]
|
#(let [(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))
|
||||||
{:arity (length args) :args arglocals :org self.org :type etype : name : call-instruction}))))
|
{:arity (length args) :args arglocals :org self.org :type etype : name : call-instruction}))))
|
||||||
|
@ -482,8 +482,9 @@
|
||||||
locals (lume.clone self.locals)
|
locals (lume.clone self.locals)
|
||||||
callid (or (. self.callsites f.name) 0)
|
callid (or (. self.callsites f.name) 0)
|
||||||
_ (tset self.callsites f.name (+ callid 1))
|
_ (tset self.callsites f.name (+ callid 1))
|
||||||
callsite-sym (.. "<callsite " self.defining-fn " " f.name ":" callid ">")
|
funcname self.defining-fn
|
||||||
capture-addr (fn [addr] (tset self.addr-to-callsite addr {: callsite-sym : locals}))
|
callsite-sym (.. "<callsite " funcname " " f.name ":" callid ">")
|
||||||
|
capture-addr (fn [addr] (tset self.addr-to-callsite (- addr 1) {: callsite-sym : locals : funcname :calling f.name}))
|
||||||
post (icollect [_ (countiter (length args))] (self:drop))]
|
post (icollect [_ (countiter (length args))] (self:drop))]
|
||||||
(values (lume.concat [:block] pre [[f.call-instruction f.name] callsite-sym [:export callsite-sym] [:meta capture-addr]] post) f.type)))
|
(values (lume.concat [:block] pre [[f.call-instruction f.name] callsite-sym [:export callsite-sym] [:meta capture-addr]] post) f.type)))
|
||||||
|
|
||||||
|
@ -541,6 +542,11 @@
|
||||||
|
|
||||||
(fn Ssc.assemble [self]
|
(fn Ssc.assemble [self]
|
||||||
(self.prg:assemble)
|
(self.prg:assemble)
|
||||||
|
(set self.prg.source self)
|
||||||
self.prg)
|
self.prg)
|
||||||
|
|
||||||
|
(fn Ssc.read-hotswap [self machine prg-new]
|
||||||
|
(local {: hotswap-stacks} (require :ssc.hotswap))
|
||||||
|
(hotswap-stacks machine self prg-new.source))
|
||||||
|
|
||||||
Ssc
|
Ssc
|
||||||
|
|
|
@ -24,7 +24,8 @@
|
||||||
[:tsc] [:and 0xff] [:ora task-base] [:tcs]])])
|
[:tsc] [:and 0xff] [:ora task-base] [:tcs]])])
|
||||||
|
|
||||||
(fn yield ()
|
(fn yield ()
|
||||||
(asm (tsc) (sta [$1.TASK-STACK])
|
(asm (tsc) (sta [$1.TASK-STACK]) ;
|
||||||
|
debug-stub on-hotswap (export debug-stub) (export on-hotswap) ; todo: cleanup mame hotswap logic
|
||||||
(lda [$1.TASK-NEXT]) (tcd)
|
(lda [$1.TASK-NEXT]) (tcd)
|
||||||
(lda [$1.TASK-STACK]) (tcs)))
|
(lda [$1.TASK-STACK]) (tcs)))
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue