honeylisp/link/mame.fnl

(local util (require :lib.util))
(local {: spawn : kill} (util.require :lib.spawn))
(local nrepl (require :link.nrepl))
(local Session (require :link.nrepl-session))
(local bencode (require :lib.bencode))
(local lume (require :lib.lume))

(fn current-pluginspath []
  (local f (io.popen "mame -showconfig" :r))
  (var pluginspath "")
  (each [line (f:lines)]
    (local path (line:match "pluginspath%s+(.*)"))
    (when path (set pluginspath path)))
  pluginspath)

(local pluginspath (.. (current-pluginspath) ";" (love.filesystem.getWorkingDirectory) "/support/mame"))
(fn start-mame [platform]
  (spawn [:mame :-debug :-plugins :-pluginspath pluginspath :-plugin :jeejah platform]))

(local Machine (Session:extend))
(fn Machine.new [self]
  (Machine.super.new self {:out (fn []) :value (fn [])})
  (set self.breakpoints {}))
(fn Machine.boot [self]
  (when (not self.pid)
    (set self.pid (start-mame :apple2gs))))
(fn Machine.run [self]
  (self:boot)
  (self:connect))
(fn Machine.die [self]
  (self:disconnect)
  (when self.pid
    (kill (- self.pid) 1)
    (set self.pid nil)))
(fn Machine.running? [self] self.pid)
(fn Machine.connected? [self] self.session)
(fn Machine.connect [self]
  (util.in-coro (fn []
    (when (not (nrepl:connected?))
      (util.waitfor
        #(if (nrepl:connected?) true
           (do (pcall #(nrepl:connect)) false))))
    (self:init-session))))
(fn Machine.init-session [self]
  (Machine.super.init-session self)
  (set self.monitor (Session {:out (fn []) :value (fn [])}))
  (self.monitor:init-session)
  (self.monitor:eval
    "(global periodic-jobs {})
     (emu.register_periodic (fn []
       (local dead-ids [])
       (each [id coro (pairs periodic-jobs)]
         (coroutine.resume coro)
         (when (= (coroutine.status coro) :dead)
           (table.insert dead-ids id)))
       (each [_ id (ipairs dead-ids)]
         (tset periodic-jobs id nil))))
     (global run-periodic-job (fn [id f]
       (tset periodic-jobs id (coroutine.running))
       (f)
       (tset periodic-jobs id nil)))")
  (self:start-cpu-monitor)
  (self:continue) ; debug mame starts paused
  (self:done-msg))

(fn Machine.start-cpu-monitor [self ?last-addr]
  (self.monitor:eval-input
    "(let [?last-addr (tonumber (io.read))]
       (run-periodic-job :cpu-monitor (fn []
         (var last-addr ?last-addr)
         (while (let [state manager.machine.debugger.execution_state
                      addr (. manager.machine.devices ::maincpu :state :PC :value)]
                    (not (and (= state :stop) (not= addr ?last-addr))))
           (when (= :run manager.machine.debugger.execution_state)
             (set last-addr nil))
           (coroutine.yield))))
       (. manager.machine.devices ::maincpu :state :PC :value))"
    (tostring ?last-addr)
    {:value (fn [nrepl output response]
              (self:on-cpu-paused (tonumber output))
              (self:start-cpu-monitor (tonumber output)))}))
(fn Machine.on-cpu-paused [self addr]
  (local action (-?> self.breakpoints (. addr) (. :action)))
  (when action (action)))
(fn Machine.disconnect [self]
  (self:shutdown-session)
  (when self.monitor (self.monitor:shutdown-session))
  (when (nrepl:connected?) (nrepl:disconnect))
  (set self.breakpoints {}))
(fn Machine.read [self addr len]
  (var bytes nil)
  (self:coro-eval
    "(let [bencode (require :bencode)
           {: addr : len} (bencode.decode (io.read))
           mem (. manager.machine.devices ::maincpu :spaces :program)]
       (var bytes \"\")
       (for [i 1 len]
         (set bytes (.. bytes (string.char (mem:read_u8 (+ addr i -1))))))
       (io.write bytes))"
    (lume.merge
      (self:input-handler (bencode.encode {: addr : len}))
      {:out #(set bytes $2)}))
  bytes)
(fn Machine.read-batch [self addr-to-len]
  (var addr-to-bytes nil)
  (self:coro-eval
    "(let [bencode (require :bencode)
           addr-to-len (bencode.decode (io.read))
           mem (. manager.machine.devices ::maincpu :spaces :program)
           addr-to-bytes {}]
       (each [addr len (pairs addr-to-len)]
         (var bytes \"\")
         (for [i 1 len]
           (set bytes (.. bytes (string.char (mem:read_u8 (+ addr i -1))))))
         (tset addr-to-bytes addr bytes))
       (io.write (bencode.encode addr-to-bytes)))"
    (lume.merge
      (self:input-handler (bencode.encode addr-to-len))
      {:out #(set addr-to-bytes (bencode.decode $2))}))
  addr-to-bytes)
(fn Machine.write [self addr bytes]
  (if (> (bytes:len) 0x1000)
        (do (self:write addr (bytes:sub 1 0x1000))
          (self:write (+ addr 0x1000) (bytes:sub 0x1001)))
    (self:eval-input
       "(let [bencode (require :bencode)
              {: addr : bytes} (bencode.decode (io.read))
              mem (. manager.machine.devices ::maincpu :spaces :program)]
          (print :writing (bytes:len) :to addr)
          (for [i 1 (bytes:len)]
            (mem:write_u8 (+ addr i -1) (string.byte (bytes:sub i i)))))"
      (bencode.encode {: addr : bytes}))))
(fn Machine.write-batch [self addr-to-bytes]
  (self:eval-input
    "(let [bencode (require :bencode)
           addr-to-bytes (bencode.decode (io.read))
           mem (. manager.machine.devices ::maincpu :spaces :program)]
       (each [addr bytes (pairs addr-to-bytes)]
         (for [i 1 (bytes:len)]
           (mem:write_u8 (+ addr i -1) (string.byte (bytes:sub i i))))))"
    (bencode.encode addr-to-bytes)))
(fn Machine.launch [self prg]
  (self:eval "(manager.machine:soft_reset)")
  (self:eval (string.format "(emu.keypost \"CALL-151\\n %xG\\n\")" (prg:lookup-addr prg.start-symbol))))
(fn Machine.reboot [self] (self:eval "(manager.machine:hard_reset)"))
(fn Machine.coro-eval [self code ?handlers]
  (var result nil)
  (local append-to-result #(set result (.. (or result "") $2)))
  (self:eval code
    (self:coro-handlers (coroutine.running)
                        (lume.merge {:value append-to-result :out append-to-result}
                                    (or ?handlers {}))))
  (coroutine.yield)
  (or result "<no result>"))
(fn Machine.dbgcmd [self cmd ?handlers]
  (self:eval (.. "(manager.machine.debugger:command \"" cmd "\")")) ?handlers)
(fn Machine.continue [self] (self:dbgcmd :go))
(fn Machine.step [self] (self:dbgcmd :s))
(fn Machine.set-bp [self addr ?action]
  ; todo: handle setting the same breakpoint more than once?
  (tset self.breakpoints addr {:action ?action})
  (self:eval (.. "(-> (. manager.machine.devices ::maincpu :debug) (: :bpset " (tostring addr) "))")
    {:value #(tset (. self.breakpoints addr) :id (tonumber $2))}))
(fn Machine.clear-bp [self addr]
  (local bpid (-?> self.breakpoints (. addr) (. :id)))
  (when bpid (self:dbgcmd (.. "bpclear 0x" (string.format "%x" bpid))))
  (tset self.breakpoints addr nil))
(fn Machine.jump [self addr]
  (self:eval (.. "(tset (. manager.machine.devices ::maincpu :state :PC) :value " (tostring addr) ")")))
(fn Machine.stub [self org post-check-jump ...]
  (org:append :debug-stub [:jmp post-check-jump] :on-hotswap ...))
(fn Machine.hotswap [self prg-old prg-new]
  (local addr (prg-old:lookup-addr :debug-stub))
  (self:set-bp addr
    #(util.in-coro (fn []
       (self:clear-bp addr)
       (local hotswap (prg-old:read-hotswap self))
       (prg-new:upload self)
       (prg-new:write-hotswap self hotswap)
       (self:jump (prg-new:lookup-addr :on-hotswap))
       (self:continue)))))

(fn Machine.overlay [self prg-overlay]
  (self:step)
  (prg-overlay:upload self)
  (self:continue))

(Machine:new)

Machine