[Guile-commits] 02/13: Add support for raw gc-managed pointer locals

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 9222e4df4b3673da662785f71d0f3c289ba8a8a5
Author: Andy Wingo <address@hidden>
Date:   Wed Jan 10 21:05:16 2018 +0100

    Add support for raw gc-managed pointer locals
    
    * libguile/vm-engine.c (gc-pointer-ref/immediate)
      (gc-pointer-set!/immediate): New instructions.
      (SP_REF_PTR, SP_SET_PTR): New helper definitions.
    * libguile/vm.c (SLOT_DESC_LIVE_GC): Rename from SLOT_DESC_LIVE_SCM, as
      it can indicate GC-protected raw pointers also.
      (scm_i_vm_mark_stack): Adapt.
    * module/system/vm/assembler.scm (write-arities):
    * module/system/vm/debug.scm (arity-definitions): Add gcptr
      representation.  This is a binary-incompatible change!
---
 libguile/vm-engine.c           | 27 +++++++++++++++++++++++++--
 libguile/vm.c                  |  6 +++---
 module/system/vm/assembler.scm |  3 ++-
 module/system/vm/debug.scm     |  7 ++++---
 4 files changed, 34 insertions(+), 9 deletions(-)

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 83eefd8..5206b96 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -269,6 +269,9 @@
 #define SP_REF_S64(i)          (sp[i].as_s64)
 #define SP_SET_S64(i,o)                (sp[i].as_s64 = o)
 
+#define SP_REF_PTR(i)          (sp[i].as_ptr)
+#define SP_SET_PTR(i,o)                (sp[i].as_ptr = o)
+
 #define VARIABLE_REF(v)                SCM_VARIABLE_REF (v)
 #define VARIABLE_SET(v,o)      SCM_VARIABLE_SET (v, o)
 #define VARIABLE_BOUNDP(v)      (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED))
@@ -1418,8 +1421,28 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (1);
     }
 
-  VM_DEFINE_OP (45, unused_45, NULL, NOP)
-  VM_DEFINE_OP (46, unused_46, NULL, NOP)
+  VM_DEFINE_OP (45, gc_pointer_ref_immediate, "gc-pointer-ref/immediate", OP1 
(X8_S8_S8_C8) | OP_DST)
+    {
+      scm_t_uint8 dst, obj, idx;
+
+      UNPACK_8_8_8 (op, dst, obj, idx);
+
+      SP_SET_PTR (dst, (void*) SCM_CELL_WORD (SP_REF (obj), idx));
+
+      NEXT (1);
+    }
+
+  VM_DEFINE_OP (46, gc_pointer_set_immediate, "gc-pointer-set!/immediate", OP1 
(X8_S8_C8_S8))
+    {
+      scm_t_uint8 obj, idx, val;
+
+      UNPACK_8_8_8 (op, obj, idx, val);
+
+      SCM_SET_CELL_WORD (SP_REF (obj), idx, (scm_t_uintptr) SP_REF_PTR (val));
+
+      NEXT (1);
+    }
+
   VM_DEFINE_OP (47, unused_47, NULL, NOP)
     {
       vm_error_bad_instruction (op);
diff --git a/libguile/vm.c b/libguile/vm.c
index 2f99692..0f107ea 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -970,7 +970,7 @@ enum slot_desc
   {
     SLOT_DESC_DEAD = 0,
     SLOT_DESC_LIVE_RAW = 1,
-    SLOT_DESC_LIVE_SCM = 2,
+    SLOT_DESC_LIVE_GC = 2,
     SLOT_DESC_UNUSED = 3
   };
 
@@ -1000,7 +1000,7 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct 
GC_ms_entry *mark_stack_ptr,
       size_t slot = nlocals - 1;
       for (slot = nlocals - 1; sp < fp; sp++, slot--)
         {
-          enum slot_desc desc = SLOT_DESC_LIVE_SCM;
+          enum slot_desc desc = SLOT_DESC_LIVE_GC;
 
           if (slot_map)
             desc = (slot_map[slot / 4U] >> ((slot % 4U) * 2)) & 3U;
@@ -1010,7 +1010,7 @@ scm_i_vm_mark_stack (struct scm_vm *vp, struct 
GC_ms_entry *mark_stack_ptr,
             case SLOT_DESC_LIVE_RAW:
               break;
             case SLOT_DESC_UNUSED:
-            case SLOT_DESC_LIVE_SCM:
+            case SLOT_DESC_LIVE_GC:
               if (SCM_NIMP (sp->as_scm) &&
                   sp->as_ptr >= lower && sp->as_ptr <= upper)
                 mark_stack_ptr = GC_mark_and_push (sp->as_ptr,
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 77b2e51..9be3fcf 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -2128,8 +2128,9 @@ procedure with label @var{rw-init}.  @var{rw-init} may be 
false.  If
                         ((f64) 1)
                         ((u64) 2)
                         ((s64) 3)
+                        ((gc-ptr) 4)
                         (else (error "what!" representation)))))
-             (put-uleb128 names-port (logior (ash slot 2) tag)))
+             (put-uleb128 names-port (logior (ash slot 3) tag)))
            (lp definitions))))))
   (let lp ((metas metas) (pos arities-prefix-len) (relocs '()))
     (match metas
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 09d0766..9818bfa 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -1,6 +1,6 @@
 ;;; Guile runtime debug information
 
-;;; Copyright (C) 2013, 2014, 2015 Free Software Foundation, Inc.
+;;; Copyright (C) 2013, 2014, 2015, 2018 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -382,12 +382,13 @@ section of the ELF image.  Returns an ELF symbol, or 
@code{#f}."
              (lambda (def-offset pos)
                (call-with-values (lambda () (read-uleb128 bv pos))
                  (lambda (slot+representation pos)
-                   (let ((slot (ash slot+representation -2))
-                         (representation (case (logand slot+representation #x3)
+                   (let ((slot (ash slot+representation -3))
+                         (representation (case (logand slot+representation #x7)
                                            ((0) 'scm)
                                            ((1) 'f64)
                                            ((2) 'u64)
                                            ((3) 's64)
+                                           ((4) 'gcptr)
                                            (else 'unknown))))
                      (cons (vector name def-offset slot representation)
                            (lp pos names)))))))))))