For a cheaper ‘bytevector->pointer’

[Ludovic Courtès]

Hello!

A few days ago David was explaining on #guile how ‘bytevector->pointer’
was generating too much garbage for his use case.  An idea we came up
with was to embed the pointer object in the bytevector.

The patch below does that but it leads to segfaults because I’m guessing
there’s generated bytecode somewhere that still uses the wrong offset; I
adjusted code that emits ‘pointer-ref/immediate’, what else did I miss?

Also, since we disable internal pointers, we’d need to register an
additional displacement, and I’m not sure if this is a good idea.

Thoughts?

Thanks,
Ludo’.

diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index 7dfdab499..00aab6911 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -196,10 +196,15 @@
   SCM_SET_BYTEVECTOR_FLAGS ((bv), SCM_BYTEVECTOR_FLAGS (bv) | flag)
 #define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len)            \
   SCM_SET_CELL_WORD_1 ((_bv), (scm_t_bits) (_len))
-#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _contents)    \
-  SCM_SET_CELL_WORD_2 ((_bv), (scm_t_bits) (_contents))
+#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _contents)             \
+  do                                                            \
+    {                                                           \
+      SCM_SET_CELL_WORD_2 ((_bv), scm_tc7_pointer);             \
+      SCM_SET_CELL_WORD_3 ((_bv), (scm_t_bits) (_contents));    \
+    }                                                           \
+  while (0)
 #define SCM_BYTEVECTOR_SET_PARENT(_bv, _parent)        \
-  SCM_SET_CELL_OBJECT_3 ((_bv), (_parent))
+  SCM_SET_CELL_OBJECT ((_bv), 4, (_parent))
 
 #define SCM_VALIDATE_MUTABLE_BYTEVECTOR(pos, v) \
   SCM_MAKE_VALIDATE_MSG (pos, v, MUTABLE_BYTEVECTOR_P, "mutable bytevector")
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index 980d6e267..77a0ef2f3 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -1,7 +1,7 @@
 #ifndef SCM_BYTEVECTORS_H
 #define SCM_BYTEVECTORS_H
 
-/* Copyright 2009,2011,2018
+/* Copyright 2009,2011,2018,2019
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -26,20 +26,23 @@
 #include "libguile/gc.h"
 
 #include "libguile/uniform.h"
+#include "libguile/foreign.h"
 
 
 /* R6RS bytevectors.  */
 
 /* The size in words of the bytevector header (type tag and flags, length,
    and pointer to the underlying buffer).  */
-#define SCM_BYTEVECTOR_HEADER_SIZE   4U
+#define SCM_BYTEVECTOR_HEADER_SIZE   5U
 
 #define SCM_BYTEVECTOR_LENGTH(_bv)             \
   ((size_t) SCM_CELL_WORD_1 (_bv))
+#define SCM_BYTEVECTOR_POINTER(_bv)             \
+  (SCM_PACK_POINTER (SCM_CELL_OBJECT_LOC ((_bv), 2)))
 #define SCM_BYTEVECTOR_CONTENTS(_bv)           \
-  ((signed char *) SCM_CELL_WORD_2 (_bv))
+  ((signed char *) SCM_POINTER_VALUE (SCM_BYTEVECTOR_POINTER (_bv)))
 #define SCM_BYTEVECTOR_PARENT(_bv)             \
-  (SCM_CELL_OBJECT_3 (_bv))
+  (SCM_CELL_OBJECT_4 (_bv))
 
 
 SCM_API SCM scm_endianness_big;
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 1368cc9da..1879c23bc 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -1,4 +1,4 @@
-/* Copyright 2010-2016,2018
+/* Copyright 2010-2016,2018,2019
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -313,8 +313,15 @@ SCM_DEFINE (scm_bytevector_to_pointer, 
"bytevector->pointer", 1, 1, 0,
     boffset = scm_to_unsigned_integer (offset, 0,
                                        SCM_BYTEVECTOR_LENGTH (bv) - 1);
 
-  ret = scm_from_pointer (ptr + boffset, NULL);
-  register_weak_reference (ret, bv);
+  if (boffset == 0)
+    /* The fast path: return the pre-allocated pointer.  */
+    ret = SCM_BYTEVECTOR_POINTER (bv);
+  else
+    {
+      ret = scm_from_pointer (ptr + boffset, NULL);
+      register_weak_reference (ret, bv);
+    }
+
   return ret;
 }
 #undef FUNC_NAME
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 8f048a504..c164f606b 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -883,7 +883,7 @@
                (letk k ($kargs ('ptr) (ptr) ,body))
                (build-term
                  ($continue k src
-                   ($primcall 'pointer-ref/immediate '(bytevector . 2)
+                   ($primcall 'pointer-ref/immediate '(bytevector . 3)
                               (bv))))))))
     (letk k ($kargs ('rlen) (rlen) ,access))
     (letk kassume
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
index 418c9fed4..438aee9df 100644
--- a/module/system/base/types.scm
+++ b/module/system/base/types.scm
@@ -1,5 +1,5 @@
 ;;; 'SCM' type tag decoding.
-;;; Copyright (C) 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
+;;; Copyright (C) 2014, 2015, 2017, 2018, 2019 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 License as published by
@@ -415,7 +415,7 @@ using BACKEND."
                                                 (match (native-endianness)
                                                   ('little "UTF-32LE")
                                                   ('big "UTF-32BE")))))
-          (((_ & #x7f = %tc7-bytevector) len address)
+          (((_ & #x7f = %tc7-bytevector) len pointer-tag address)
            (let ((bv-port (memory-port backend address len)))
              (get-bytevector-n bv-port len)))
           ((((len << 8) || %tc7-vector))