[Guile-commits] 01/02: DRAFT: VM: Add a 'tag' argument to the 'static-patch!' instruction.

[Mark H. Weaver]

mhw pushed a commit to branch wip-new-tagging-bis-broken
in repository guile.

commit 92a7168fbebbf94aff7bbfc9192d26b55a98d3e5
Author: Mark H Weaver <address@hidden>
Date:   Sat Jun 8 01:06:55 2019 -0400

    DRAFT: VM: Add a 'tag' argument to the 'static-patch!' instruction.
---
 libguile/jit.c                 | 12 +++++++++++-
 libguile/vm-engine.c           | 15 +++++++++------
 module/system/vm/assembler.scm | 10 +++++-----
 3 files changed, 25 insertions(+), 12 deletions(-)

diff --git a/libguile/jit.c b/libguile/jit.c
index 6cea8bb..5350982 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -2385,9 +2385,11 @@ compile_static_set (scm_jit_state *j, uint32_t obj, void 
*loc)
 }
 
 static void
-compile_static_patch (scm_jit_state *j, void *dst, const void *src)
+compile_static_patch (scm_jit_state *j, uint32_t tag, void *dst, const void 
*src)
 {
   emit_movi (j, T0, (uintptr_t) src);
+  if (tag)
+    emit_addi (j, T0, T0, tag);
   jit_sti (j->jit, dst, T0);
 }
 
@@ -4392,6 +4394,14 @@ compile_f64_set (scm_jit_state *j, uint8_t ptr, uint8_t 
idx, uint8_t v)
     comp (j, j->ip + a, j->ip + b);                                     \
   }
 
+#define COMPILE_X8_S24__LO32__L32(j, comp)                              \
+  {                                                                     \
+    uint32_t a;                                                         \
+    int32_t b = j->ip[1], c = j->ip[2];                                 \
+    UNPACK_24 (j->ip[0], a);                                            \
+    comp (j, a, j->ip + b, j->ip + c);                                  \
+  }
+
 #define COMPILE_X8_F24__X8_C24__L32(j, comp)                            \
   {                                                                     \
     uint32_t a, b;                                                      \
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 062dc00..e089d4f 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -2192,23 +2192,26 @@ VM_NAME (scm_thread *thread)
       NEXT (2);
     }
 
-  /* static-patch! _:24 dst-offset:32 src-offset:32
+  /* static-patch! tag:24 dst-offset:32 src-offset:32
    *
-   * Patch a pointer at DST-OFFSET to point to SRC-OFFSET.  Both offsets
-   * are signed 32-bit values, indicating a memory address as a number
-   * of 32-bit words away from the current instruction pointer.
+   * Patch a pointer at DST-OFFSET to point to SRC-OFFSET, with TAG
+   * added in the low bits.  Both offsets are signed 32-bit values,
+   * indicating a memory address as a number of 32-bit words away from
+   * the current instruction pointer.
    */
-  VM_DEFINE_OP (86, static_patch, "static-patch!", OP3 (X32, LO32, L32))
+  VM_DEFINE_OP (86, static_patch, "static-patch!", OP3 (X8_S24, LO32, L32))
     {
       int32_t dst_offset, src_offset;
       void *src;
       void** dst_loc;
+      uint32_t tag;
 
+      UNPACK_24 (op, tag);
       dst_offset = ip[1];
       src_offset = ip[2];
 
       dst_loc = (void **) (ip + dst_offset);
-      src = ip + src_offset;
+      src = (char *) (ip + src_offset) + tag;
       VM_ASSERT (ALIGNED_P (dst_loc, void*), abort());
 
       *dst_loc = src;
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index f3682f7..241d285 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1170,7 +1170,7 @@ table, its existing label is used directly."
     (let ((src (recur obj)))
       (if src
           (if (statically-allocatable? obj)
-              `((static-patch! ,dst ,n ,src))
+              `((static-patch! 0 ,dst ,n ,src))
               `((static-ref 1 ,src)
                 (static-set! 1 ,dst ,n)))
           '())))
@@ -1192,7 +1192,7 @@ table, its existing label is used directly."
               (field label 3 (syntax-module obj))))
      ((stringbuf? obj) '())
      ((static-procedure? obj)
-      `((static-patch! ,label 1 ,(static-procedure-code obj))))
+      `((static-patch! 0 ,label 1 ,(static-procedure-code obj))))
      ((cache-cell? obj) '())
      ((symbol? obj)
       (unless (symbol-interned? obj)
@@ -1201,7 +1201,7 @@ table, its existing label is used directly."
         (string->symbol 1 1)
         (static-set! 1 ,label 0)))
      ((string? obj)
-      `((static-patch! ,label 1 ,(recur (make-stringbuf obj)))))
+      `((static-patch! 0 ,label 1 ,(recur (make-stringbuf obj)))))
      ((keyword? obj)
       `((static-ref 1 ,(recur (keyword->symbol obj)))
         (symbol->keyword 1 1)
@@ -1222,12 +1222,12 @@ table, its existing label is used directly."
                      ((u64 s64 f64 c64) 8)
                      (else
                       (error "unhandled array type" obj)))))
-        `((static-patch! ,label 2
+        `((static-patch! 0 ,label 2
                          ,(recur (make-uniform-vector-backing-store
                                   (uniform-array->bytevector obj)
                                   width))))))
      ((array? obj)
-      `((static-patch! ,label 1 ,(recur (shared-array-root obj)))))
+      `((static-patch! 0 ,label 1 ,(recur (shared-array-root obj)))))
      (else
       (error "don't know how to intern" obj))))
   (cond