rtl: propagate OP_DST to scheme

* libguile/instructions.c (scm_rtl_instruction_list): Add an element to
  the list to indicate that an instruction outputs to its first
  argument.

* module/system/vm/assembler.scm:
* module/system/vm/disassembler.scm: Adapt.

diff --git a/libguile/instructions.c b/libguile/instructions.c
index 9e8ccb4..9bb50f4 100644 (file)
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -41,6 +41,10 @@ struct scm_instruction {
 };
 
 
+SCM_SYMBOL (sym_left_arrow, "<-");
+SCM_SYMBOL (sym_bang, "!");
+
+
 #define OP_HAS_ARITY (1U << 0)
 
 #define FOR_EACH_INSTRUCTION_WORD_TYPE(M)       \
@@ -274,6 +278,7 @@ SCM_DEFINE (scm_rtl_instruction_list, "rtl-instruction-list", 0, 0, 0,
           case 1:
             tail = scm_cons (word_type_symbols[WORD_TYPE (0, meta)], tail);
           default:
+            tail = scm_cons ((meta & OP_DST) ? sym_left_arrow : sym_bang, tail);
             tail = scm_cons (scm_from_int (ip[i].opcode), tail);
             tail = scm_cons (ip[i].symname, tail);
             break;

diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 556f589..ad65be4 100644 (file)
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -443,7 +443,7 @@ later by the linker."
 (define-syntax define-assembler
   (lambda (x)
     (syntax-case x ()
-      ((_ name opcode arg ...)
+      ((_ name opcode kind arg ...)
        (with-syntax ((emit (id-append #'name #'emit- #'name)))
          #'(define emit
              (let ((emit (assembler name opcode arg ...)))

diff --git a/module/system/vm/disassembler.scm b/module/system/vm/disassembler.scm
index b815c1e..1c6a097 100644 (file)
--- a/module/system/vm/disassembler.scm
+++ b/module/system/vm/disassembler.scm
@@ -181,7 +181,7 @@
 (define-syntax define-disassembler
   (lambda (x)
     (syntax-case x ()
-      ((_ name opcode arg ...)
+      ((_ name opcode kind arg ...)
        (with-syntax ((parse (id-append #'name #'parse- #'name)))
          #'(let ((parse (disassembler name opcode arg ...)))
              (vector-set! disassemblers opcode parse)))))))