vm/asm: new swtch instruction.

* share/txr/stdlib/asm.tl (backpatch-low16, backpatch-high16):
New struct types.
(%backpatch-low16%, %backpatch-high16%): New global variables.
(swtch): New opcode.
(op-swtch): New opcode class.

* vm.c (vm_swtch): New static function.
(vm_execute): Handle SWTCH opcode via vm_swtch.

* vmop.h: Regenerated.

3 files changed, 80 insertions, 18 deletions

diff --git a/share/txr/stdlib/asm.tl b/share/txr/stdlib/asm.tl
index 88c801e2..bba50b39 100644
--- a/share/txr/stdlib/asm.tl
+++ b/share/txr/stdlib/asm.tl
@@ -279,6 +279,21 @@
       (2 (chr-int val))
       (t (error "assembler: bad immediate operand: ~s" bits)))))
 
+(defstruct backpatch-low16 nil
+  (:method backpatch (me asm at offs)
+    (tree-bind (hi lo) asm.(get-pair)
+      asm.(set-pos at)
+      asm.(put-pair hi offs))))
+
+(defstruct backpatch-high16 nil
+  (:method backpatch (me asm at offs)
+    (tree-bind (hi lo) asm.(get-pair)
+      asm.(set-pos at)
+      asm.(put-pair offs lo))))
+
+(defvarl %backpatch-low16% (new backpatch-low16))
+(defvarl %backpatch-high16% (new backpatch-high16))
+
 (defmacro defopcode (class symbol code . slot-defs)
   ^(symacrolet ((auto (pinc %oc-code%)))
      (defstruct ,class oc-base
@@ -512,6 +527,31 @@
 
 (defopcode-derived op-ifql ifql auto op-ifq)
 
+(defopcode op-swtch swtch auto
+  (:method asm (me asm syntax)
+    me.(chk-arg-count-min 1 syntax)
+    (let* ((args asm.(parse-args me syntax '(r)))
+           (lbls (cddr syntax))
+           (tblsz (len lbls)))
+      asm.(put-insn me.code tblsz (car args))
+      (while lbls
+        (let ((x asm.(lookup-label (pop lbls) %backpatch-low16%))
+              (y (if lbls
+                   asm.(lookup-label (pop lbls) %backpatch-high16%)
+                   0)))
+          asm.(put-pair y x)))))
+
+  (:method dis (me asm tblsz switch-val)
+    (build
+      (add me.symbol)
+      (add (operand-to-sym switch-val))
+      (while (> tblsz 0)
+        (dec tblsz 2)
+        (tree-bind (y x) asm.(get-pair)
+          (add x)
+          (unless (minusp tblsz)
+            (add y)))))))
+
 (defopcode-derived op-uwprot uwprot auto op-jmp)
 
 (defopcode op-block block auto
diff --git a/vm.c b/vm.c
index 2e42d211..cc1df792 100644
--- a/vm.c
+++ b/vm.c
@@ -45,6 +45,7 @@
 #include "args.h"
 #include "itypes.h"
 #include "buf.h"
+#include "arith.h"
 #include "vmop.h"
 #include "vm.h"
 
@@ -585,6 +586,23 @@ static void vm_ifql(struct vm *vm, vm_word_t insn)
     vm->ip = vm_insn_bigop(ip);
 }
 
+static void vm_swtch(struct vm *vm, vm_word_t insn)
+{
+  unsigned tblsz = vm_insn_extra(insn);
+  ucnum idx = c_unum(vm_get(vm->dspl, vm_insn_operand(insn)));
+
+  if (idx < tblsz) {
+    vm_word_t tgt = vm->code[vm->ip + idx / 2];
+    unsigned shift = (idx % 2) * 16;
+    vm->ip = (tgt >> shift) & 0xFFFFU;
+  } else {
+    struct vm_desc *vd = vm->vd;
+    eval_error(vd->bytecode,
+               lit("switch index ~s is out of range"),
+               num(idx), nao);
+  }
+}
+
 static void vm_uwprot(struct vm *vm, vm_word_t insn)
 {
   int saved_lev = vm->lev;
@@ -846,6 +864,9 @@ static val vm_execute(struct vm *vm)
     case IFQL:
       vm_ifql(vm, insn);
       break;
+    case SWTCH:
+      vm_swtch(vm, insn);
+      break;
     case UWPROT:
       vm_uwprot(vm, insn);
       break;
diff --git a/vmop.h b/vmop.h
index 827340e2..d1e26f34 100644
--- a/vmop.h
+++ b/vmop.h
@@ -46,22 +46,23 @@ typedef enum vm_op {
   IF = 17,
   IFQ = 18,
   IFQL = 19,
-  UWPROT = 20,
-  BLOCK = 21,
-  RETSR = 22,
-  RETRS = 23,
-  RETRR = 24,
-  ABSCSR = 25,
-  CATCH = 26,
-  HANDLE = 27,
-  GETV = 28,
-  GETF = 29,
-  GETL1 = 30,
-  GETVB = 31,
-  GETFB = 32,
-  GETL1B = 33,
-  SETV = 34,
-  SETL1 = 35,
-  BINDV = 36,
-  CLOSE = 37,
+  SWTCH = 20,
+  UWPROT = 21,
+  BLOCK = 22,
+  RETSR = 23,
+  RETRS = 24,
+  RETRR = 25,
+  ABSCSR = 26,
+  CATCH = 27,
+  HANDLE = 28,
+  GETV = 29,
+  GETF = 30,
+  GETL1 = 31,
+  GETVB = 32,
+  GETFB = 33,
+  GETL1B = 34,
+  SETV = 35,
+  SETL1 = 36,
+  BINDV = 37,
+  CLOSE = 38,
 } vm_op_t;