From dab1881d90ab1514301a081a9dbc265325672b20 Mon Sep 17 00:00:00 2001
From: Jeremy Penner <jeremy@sporktania.com>
Date: Tue, 17 Nov 2020 15:35:41 -0500
Subject: [PATCH] Honeylisp VM eval!

---
 asm/vm.fnl    | 59 ++++++++++++++++++++++++++++++++++++++++-----------
 game/init.fnl |  1 +
 link/mame.fnl |  4 ++++
 wrap.fnl      | 13 ++++++++++++
 4 files changed, 65 insertions(+), 12 deletions(-)

diff --git a/asm/vm.fnl b/asm/vm.fnl
index ab947f6..a1f0e4a 100644
--- a/asm/vm.fnl
+++ b/asm/vm.fnl
@@ -1,6 +1,7 @@
 (local lume (require "lib.lume"))
 (local {: lo : hi} (require "lib.util"))
 (local link (require :link))
+(local asm (require :asm.asm))
 
 (fn inc16-stk [l h]
   [:block
@@ -35,9 +36,7 @@
     :go
   ])
 
-(fn mk-vm [prg options]
-  (local code1 (prg:org 0xc00))
-
+(fn install-vm-parser [prg]
   (fn prg.dat-parser.vm [bytecodes]
     (local block (prg:new-block))
     (each [_ bytecode (ipairs (lume.slice bytecodes 2))]
@@ -52,7 +51,11 @@
         (prg:parse-dats block [bytecode])
 
         (error (.. "VM can't parse " (fv bytecode)))))
-    block)
+    block))
+
+(fn mk-vm [prg options]
+  (local code1 (prg:org 0xc00))
+  (install-vm-parser prg)
   (local vm {
     :IP   :0x60
     :IPH  :0x61
@@ -82,10 +85,10 @@
     :drop (fn [self] [:block [:dex] [:dex]])
     :def
     (fn [self name ...]
-      (code1:append name [:flatten ...] (self:ret)))
+      (self.code:append name [:flatten ...] (self:ret)))
     :word
     (fn [self name ...]
-      (code1:append name [:jsr :subroutine] [:vm ...] [:vm :ret]))
+      (self.code:append name [:jsr :subroutine] [:vm ...] [:vm :ret]))
     :inline
     (fn [self ...]
       [:block [:jsr :subroutine] [:vm ...] [:vm :restore]])
@@ -96,7 +99,7 @@
     (fn [self ...]
       (if link.machine.stub
         (do
-          (link.machine:stub code1 :next
+          (link.machine:stub self.code :next
             [:lda #(lo ($1:lookup-addr :G-POST-HOTSWAP-RESET))]
             [:sta self.IP]
             [:lda #(hi ($1:lookup-addr :G-POST-HOTSWAP-RESET))]
@@ -105,8 +108,9 @@
           [:block [:vm :debug-stub :jmp :no-hotswap-reset [:block :G-POST-HOTSWAP-RESET] ...] :no-hotswap-reset])
         [:block]))
   })
+  (set prg.vm vm)
 
-  (code1:append :next
+  (vm.code:append :next
     [:ldy 0]
     [:lda [vm.IP] :y]  [:sta vm.W]
     (inc16 vm.IP vm.IPH)
@@ -115,7 +119,7 @@
 
     [:jmp [vm.W]])
 
-  (code1:append :reset
+  (vm.code:append :reset
     [:lda #(lo ($1:lookup-addr :quit))]
     [:sta vm.IP]
     [:lda #(hi ($1:lookup-addr :quit))]
@@ -141,9 +145,9 @@
     [:dey] [:lda vm.RSTACK :y] [:sta vm.IP]
     [:sty vm.ROFF])
 
-  (code1:append :native [:jmp [vm.IP]])
-  (code1:append :quit [:rts])
-  (code1:append :restore
+  (vm.code:append :native [:jmp [vm.IP]])
+  (vm.code:append :quit [:rts])
+  (vm.code:append :restore
     [:lda vm.IP]  [:sta vm.W]
     [:lda vm.IPH] [:sta vm.WH]
     [:ldy vm.ROFF]
@@ -152,6 +156,11 @@
     [:sty vm.ROFF]
     [:jmp [vm.W]])
 
+  (vm.code:append :execute
+    [:lda vm.TOP :x] [:sta vm.W]
+    [:lda vm.TOPH :x] [:sta vm.WH]
+    (vm:drop)
+    [:jmp [vm.W]])
 
   (vm:def :drop (vm:drop))
 
@@ -325,6 +334,32 @@
       (if (= (type init) :table) init
           [:dw init])))
 
+  (fn vm.defer [self name ?init]
+    (self.code:append name [:jmp (or ?init :next)]))
+
+  (vm:word :redefine ; xp deferredxp --
+    1 :+ :set)
+
+  (fn vm.override-deferred-parent [self prg name redirect]
+    (local addr (prg.prg-base:lookup-addr name))
+    (local org (prg:org (+ addr 1)))
+    (org:append [:ref redirect]))
+
+  (vm:defer :interactive-eval-checkpoint)
+
+  (fn vm.gen-eval-prg [self vmcode]
+    (local eval-prg (asm.new self.code.prg))
+    (install-vm-parser eval-prg)
+    (local org (eval-prg:org self.code.org))
+    (org:append :code-to-eval
+      [:jsr :subroutine]
+      [:vm :lit :next :lit :interactive-eval-checkpoint :redefine]
+      vmcode
+      [:vm :ret])
+    (self:override-deferred-parent eval-prg :interactive-eval-checkpoint :code-to-eval)
+    (eval-prg:assemble)
+    eval-prg)
+
   (vm:def :+ ; a b -- c
     [:clc]
     [:lda vm.ST1 :x] [:adc vm.TOP :x] [:sta vm.ST1 :x]
diff --git a/game/init.fnl b/game/init.fnl
index a25d6a6..44d3b65 100644
--- a/game/init.fnl
+++ b/game/init.fnl
@@ -273,6 +273,7 @@
     :full-redraw
     (vm:forever
       (vm:hotswap-sync :full-redraw)
+      :interactive-eval-checkpoint
       :handle-key
     )
     :quit])
diff --git a/link/mame.fnl b/link/mame.fnl
index 9659ebc..4c3e257 100644
--- a/link/mame.fnl
+++ b/link/mame.fnl
@@ -121,6 +121,10 @@
            (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)
 
diff --git a/wrap.fnl b/wrap.fnl
index 9e3a221..fe27eb4 100644
--- a/wrap.fnl
+++ b/wrap.fnl
@@ -21,6 +21,18 @@
       (core.log "Reloaded!")
       (core.log "Reload failed")))
 })
+
+(command.add #(and (link.machine:connected?) link.machine.overlay) {
+  "honeylisp:vm-eval" (fn []
+    (fn vm-eval [code]
+      (local vmcode (fennel.eval (.. "[:vm " code "]") {:env _G :compiler-env _G}))
+      (local prg (require :game))
+      (local overlay (prg.vm:gen-eval-prg vmcode))
+      (link.machine:overlay overlay)
+      "")
+    (editor.inline-eval vm-eval))
+})
+
 (command.add (fn [] true) {
   "honeylisp:rebuild" #(util.reload "game")
 })
@@ -53,6 +65,7 @@
 })
 (keymap.add {
   "alt+e" "fennel:eval"
+  "alt+v" "honeylisp:vm-eval"
   "alt+r" "lume:hotswap"
   "alt+a" "honeylisp:address"
   "alt+l" "honeylisp:reload"