honeylisp/link/udpdebug.fnl

(local core (require :core))
(local socket (require :socket))
(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"
  :port 6502
})

{:cmd {
   :write 0
   :read 1
   :eval 2
   :pause 3
   :ping 4
 }
 :response {
   :ack 0
   :data 1
 }
 :pending {}
 :msgid 0
 :waiting false
 :queue []
 :connect
 (fn [self ?port ?host]
   (when (not self.connection)
     (local [port host] [(or ?port config.port) (or ?host config.host)])
     (set self.connection (assert (socket.udp)))
     (assert (self.connection:setpeername host port))
     (self.connection:settimeout 0)
     (core.add_thread #(while (self:connected?) (self:receive) (coroutine.yield)) self.connection)))
 :connected? (fn [self] (not= self.connection nil))
 :disconnect
 (fn [self]
   (when self.connection
     (self.connection:close)
     (set self.connection nil)
     (set self.pending {})
     (set self.queue [])
     (set self.waiting false)))
 :next-msgid
 (fn [self]
   (set self.msgid (lo (+ self.msgid 1)))
   self.msgid)
 :send
 (fn [self cmd ?data ?callback]
   (self:enqueue
     #(let [msgid (self:next-msgid)
            msg (.. (string.char msgid cmd) (or ?data ""))]
        (print "sending" msgid cmd (length msg))
        (when ?callback
          (tset self.pending msgid ?callback)
          (set self.waiting true))
        (self.connection:send msg))))
 :receive
 (fn [self]
   (when self.connection
     (let [data (self.connection:receive)]
       (when data
         (let [msgid (string.byte (data:sub 1 1))
               cmd   (string.byte (data:sub 2 2))
               pendingfn (. self.pending msgid)]
           (print "recieved" msgid cmd)
           (when pendingfn
             (tset self.pending msgid nil)
             (pendingfn self cmd (data:sub 3)))
           (set self.waiting false)))
       (when (and (not self.waiting) (> (length self.queue) 0))
         (let [f (. self.queue 1)]
           (table.remove self.queue 1)
           (f))))))
 :enqueue (fn [self f] (table.insert self.queue f))
 :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)]
     (self:send cmd ?data #(coroutine.resume coro $2 $3))
     (coroutine.yield)))
 :handle-ack (fn [self cmd] (assert (= cmd self.response.ack)))
 :split-batches (fn [self blocks max-size]
   ; just make sure it's legal, not optimal - no need to solve an NP-hard bin-packing problem
   (fn add-to-batch [batches iblock size]
     (let [batch (. batches (length batches))
           block (. blocks iblock)]
       (if (= block nil) batches
           ; must be split into multiple batches
           (> block.len max-size)
           (do (for [i 0 (- block.len 1) max-size]
                 (when (and (= i 0) (= (length batch) 0)) (table.remove batches))
                 (table.insert batches [{:addr (+ block.addr i)
                                         :data (when block.data (block.data:sub (+ i 1) (+ i max-size)))
                                         :len (math.min (- block.len i) max-size)
                                         :offset 1
                                         :append-to-addr block.addr}]))
               (add-to-batch batches (+ iblock 1) (if (= (% block.len max-size) 0) max-size (% block.len max-size))))
           ; we have run off the end of the current batch
           (> (+ size block.len) max-size)
           (do (table.insert batches [])
               (add-to-batch batches iblock 0))
         ; there is enough space to fit into the current batch
         (do (set block.offset (+ size 1))
             (table.insert batch block)
             (add-to-batch batches (+ iblock 1) (+ size block.len))))))
   (add-to-batch [[]] 1 0))
 :read-batch (fn [self addr-to-len]
   (let [blocks (icollect [addr len (pairs addr-to-len)] {: addr : len})
         result {}]
     (each [_ batch (ipairs (self:split-batches blocks 1450))]
       (let [msg (.. (int16-to-bytes (length batch))
                     (table.concat (icollect [_ {: addr : len} (ipairs batch)] (.. (int32-to-bytes addr) (int16-to-bytes len)))))
             (response data) (self:coro-send self.cmd.read msg)]
         (assert (= response self.response.data))
         (each [_ {: addr : len : offset : append-to-addr} (ipairs batch)]
           (let [read-data (data:sub offset (+ offset len -1))]
             (if append-to-addr (tset result append-to-addr (.. (. result append-to-addr) read-data))
               (tset result addr read-data))))))
     result))
 :read (fn [self addr len] (. (self:read-batch {addr len}) addr))
 :write-batch (fn [self addr-to-data]
   (let [blocks (icollect [addr data (pairs addr-to-data)] {: addr :len (+ (length data) 6) : data})]
     (each [_ batch (ipairs (self:split-batches blocks 1450))]
       (let [msg (.. (int16-to-bytes (length batch))
                     (table.concat (icollect [_ {: addr : data} (ipairs batch)] (.. (int32-to-bytes addr) (int16-to-bytes (length data)) data))))]
         (print "writing batch of size" (length batch) (length msg))
         (self:send self.cmd.write msg self.handle-ack)))))
 :write (fn [self addr data] (self:write-batch {addr data}))
 :pause  (fn [self] (self:send self.cmd.pause (int16-to-bytes 0xffff) self.handle-ack))
 :resume (fn [self] (self:send self.cmd.pause (int16-to-bytes 0) self.handle-ack))
 :launch (fn [self prg] (self:jump (prg:lookup-addr prg.start-symbol)))
 :hotswap
 (fn [self prg-old prg-new]
   (in-coro (fn []
     (self:pause)
     (local hotswap (prg-old:read-hotswap self prg-new))
     (prg-new:upload self)
     (prg-new:write-hotswap self hotswap)
     (self:resume))))
}