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 :apple2p))))
(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.write [self addr bytes]
  (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.launch [self prg]
  (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) :soft_reset)"))
(fn Machine.coro-eval [self code]
  (var result nil)
  (local append-to-result #(set result (.. (or result "") $2)))
  (self:eval code
    (self:coro-handlers (coroutine.running) {:value append-to-result :out append-to-result}))
  (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 " (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
    (fn [] (self:clear-bp addr)
           (prg-new:upload self)
           (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