Immediate pointers

[Ludovic Courtès]

Hello!

While using (system foreign) in a couple of projects I found myself
doing quite a bit of pointer arithmetic in Scheme:

--8<---------------cut here---------------start------------->8---
(define (foreign-array->list array-pointer element-count)
  (let ((array (pointer->bytevector array-pointer
                                    (* element-count (sizeof '*)))))
    (unfold (cut >= <> element-count)
            (lambda (element)
              (let ((start (* element (sizeof '*))))
                (bytevector->pointer array start)))
            1+
            0)))

(define (pointer+ array-pointer type index)
  (let ((offset (* index (align (sizeof type) (alignof type)))))
    (make-pointer (+ (pointer-address array-pointer) offset))))

(define (foreign-string-array->list array len)
  ;; Return a list of string comprising the LEN strings pointed to by the
  ;; elements of ARRAY, a pointer to an array of pointers.
  (unfold (cut < <> 0)
          (lambda (index)
            (let ((ptr (make-pointer (+ (pointer-address array)
                                        (* index (sizeof '*))))))
             (pointer->string (dereference-pointer ptr))))
          1-
          (- len 1)))
--8<---------------cut here---------------end--------------->8---

(Examples from
<https://gforge.inria.fr/plugins/scmgit/cgi-bin/gitweb.cgi?p=hubble/hubble.git;a=blob;f=modules/simgrid.scm>.)

The problem is that each ‘make-pointer’ call (and ‘dereference-pointer’,
etc.) conses.  This can make conversion to/from C quite inefficient.

In addition, 90% of the C pointers of interest are 8-byte aligned---that’s
on x86_64-linux-gnu, but it surely holds on most platforms, at least for
pointers returned by ‘malloc’.

So, here comes the idea of “immediate pointers”, which would fit in a
word.  A 3-bit tag is used, as for immediate numbers & co; pointers that
aren’t 8-byte aligned are still stored in an scm_tc7_pointer cell.

I experimented with it using ‘scm_tc3_unused’ (== 3).  Alas, that can’t
work, because it makes it impossible to use such an object as the ‘car’
of a pair:

  #define SCM_I_CONSP(x)  (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0))

I would welcome feedback and help from tag-savvy people.

Thanks,
Ludo’.

>From c705f743031b305051549928cd91e5cfdfef7ec7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <address@hidden>
Date: Sun, 30 Jan 2011 23:28:13 +0100
Subject: [PATCH] Attempt to support "immediate pointers".

Problem is, 3 is not a valid "immediate tag", because that would prevent
using an immediate number as the car of a pair.
---
 libguile/evalext.c |    7 +++++--
 libguile/foreign.c |    8 ++++----
 libguile/foreign.h |   12 +++++++++---
 libguile/gc.c      |    6 ++++--
 libguile/goops.c   |    3 +++
 libguile/hash.c    |   25 +++++++++++++++----------
 libguile/print.c   |    3 +++
 libguile/tags.h    |    6 +++---
 8 files changed, 46 insertions(+), 24 deletions(-)

diff --git a/libguile/evalext.c b/libguile/evalext.c
index ff2ff0e..c9dcf8b 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -1,5 +1,6 @@
-/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010 Free 
Software Foundation, Inc.
- * 
+/* Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2006, 2008,
+ *   2009, 2010, 2011 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 the Free Software Foundation; either version 3 of
@@ -72,6 +73,8 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 
0,
     case scm_tc3_imm24:
        /* characters, booleans, other immediates */
       return scm_from_bool (!scm_is_null_and_not_nil (obj));
+    case scm_tc3_aligned_pointer:
+      return SCM_BOOL_T;
     case scm_tc3_cons:
       switch (SCM_TYP7 (obj))
        {
diff --git a/libguile/foreign.c b/libguile/foreign.c
index 52da23f..d00d4a9 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -60,7 +60,7 @@ SCM_SYMBOL (sym_null, "%null-pointer");
 SCM_SYMBOL (sym_null_pointer_error, "null-pointer-error");
 
 /* The cell representing the null pointer.  */
-static SCM null_pointer;
+static SCM null_pointer =  SCM_PACK (scm_tc3_aligned_pointer);
 
 #if SIZEOF_VOID_P == 4
 # define scm_to_uintptr   scm_to_uint32
@@ -139,8 +139,9 @@ scm_from_pointer (void *ptr, scm_t_pointer_finalizer 
finalizer)
 {
   SCM ret;
 
-  if (ptr == NULL && finalizer == NULL)
-    ret = null_pointer;
+  if (SCM_LIKELY (((scm_t_uintptr) ptr & 3) == 0 && finalizer == NULL))
+    /* Return an immediate pointer.  */
+    ret = SCM_PACK ((scm_t_bits) ptr | scm_tc3_aligned_pointer);
   else
     {
       ret = scm_cell (scm_tc7_pointer, (scm_t_bits) ptr);
@@ -1125,7 +1126,6 @@ scm_init_foreign (void)
 #endif
              );
 
-  null_pointer = scm_cell (scm_tc7_pointer, 0);
   scm_define (sym_null, null_pointer);
 }
 
diff --git a/libguile/foreign.h b/libguile/foreign.h
index b290019..bf16126 100644
--- a/libguile/foreign.h
+++ b/libguile/foreign.h
@@ -49,12 +49,18 @@ typedef enum scm_t_foreign_type scm_t_foreign_type;
 
 typedef void (*scm_t_pointer_finalizer) (void *);
 
-#define SCM_POINTER_P(x)                                                \
-  (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_pointer)
+#define SCM_POINTER_P(x)                       \
+  (SCM_IMP (x)                                 \
+   ? SCM_ITAG3 (x) == scm_tc3_aligned_pointer  \
+   : SCM_TYP7 (x) == scm_tc7_pointer)
+
 #define SCM_VALIDATE_POINTER(pos, x)           \
   SCM_MAKE_VALIDATE (pos, x, POINTER_P)
+
 #define SCM_POINTER_VALUE(x)                   \
-  ((void *) SCM_CELL_WORD_1 (x))
+  (SCM_IMP (x)                                 \
+   ? (void *) ((scm_t_uintptr) (x) & ~3UL)     \
+   : (void *) SCM_CELL_WORD_1 (x))
 
 SCM_API SCM scm_from_pointer (void *, scm_t_pointer_finalizer);
 
diff --git a/libguile/gc.c b/libguile/gc.c
index 91250ba..1754f6b 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -1,4 +1,5 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 
2009, 2010 Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+ *   2006, 2008, 2009, 2010, 2011 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
@@ -746,8 +747,9 @@ scm_i_tag_name (scm_t_bits tag)
       return "cons (immediate car)";
     case scm_tcs_cons_nimcar:
       return "cons (non-immediate car)";
+    case scm_tc3_aligned_pointer:
     case scm_tc7_pointer:
-      return "foreign";
+      return "pointer";
     case scm_tc7_hashtable:
       return "hashtable";
     case scm_tc7_fluid:
diff --git a/libguile/goops.c b/libguile/goops.c
index c597044..feb61ff 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -211,6 +211,9 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
       else
         return scm_class_unknown;
 
+    case scm_tc3_aligned_pointer:
+      return class_foreign;
+
     case scm_tc3_cons:
       switch (SCM_TYP7 (x))
        {
diff --git a/libguile/hash.c b/libguile/hash.c
index 0dcd1c2..7ceea43 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -143,6 +143,18 @@ scm_i_utf8_string_hash (const char *str, size_t len)
   return h;
 }
 
+static unsigned long
+pointer_hash (SCM obj)
+{
+  /* Pointer objects are typically used to store addresses of heap
+     objects.  On most platforms, these are at least 3-byte
+     aligned (on x86_64-*-gnu, `malloc' returns 4-byte aligned
+     addresses), so get rid of the least significant bits.  */
+  scm_t_uintptr significant_bits;
+
+  significant_bits = (scm_t_uintptr) SCM_POINTER_VALUE (obj) >> 4UL;
+  return (size_t) significant_bits;
+}
 
 /* Dirk:FIXME:: why downcase for characters? (2x: scm_hasher, scm_ihashv) */
 /* Dirk:FIXME:: scm_hasher could be made static. */
@@ -155,6 +167,8 @@ scm_hasher(SCM obj, unsigned long n, size_t d)
   case scm_tc3_int_1: 
   case scm_tc3_int_2:
     return SCM_I_INUM(obj) % n;   /* SCM_INUMP(obj) */
+  case scm_tc3_aligned_pointer:
+    return pointer_hash (obj) % n;
   case scm_tc3_imm24:
     if (SCM_CHARP(obj))
       return (unsigned)(scm_c_downcase(SCM_CHAR(obj))) % n;
@@ -214,16 +228,7 @@ scm_hasher(SCM obj, unsigned long n, size_t d)
     case scm_tc7_symbol:
       return scm_i_symbol_hash (obj) % n;
     case scm_tc7_pointer:
-      {
-       /* Pointer objects are typically used to store addresses of heap
-          objects.  On most platforms, these are at least 3-byte
-          aligned (on x86_64-*-gnu, `malloc' returns 4-byte aligned
-          addresses), so get rid of the least significant bits.  */
-       scm_t_uintptr significant_bits;
-
-       significant_bits = (scm_t_uintptr) SCM_POINTER_VALUE (obj) >> 4UL;
-       return (size_t) significant_bits  % n;
-      }
+      return pointer_hash (obj) % n;
     case scm_tc7_wvect:
     case scm_tc7_vector:
       {
diff --git a/libguile/print.c b/libguile/print.c
index 679327a..f5af191 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -499,6 +499,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
          scm_ipruk ("immediate", exp, port);
        }
       break;
+    case scm_tc3_aligned_pointer:
+      scm_i_pointer_print (exp, port, pstate);
+      break;
     case scm_tc3_cons:
       switch (SCM_TYP7 (exp))
        {
diff --git a/libguile/tags.h b/libguile/tags.h
index 9e0e305..913064d 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -3,8 +3,8 @@
 #ifndef SCM_TAGS_H
 #define SCM_TAGS_H
 
-/* Copyright (C) 
1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2008,2009,2010
- * Free Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+ *   2003, 2004, 2008, 2009, 2010, 2011 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
@@ -386,7 +386,7 @@ typedef scm_t_uintptr scm_t_bits;
 #define scm_tc3_cons            0
 #define scm_tc3_struct          1
 #define scm_tc3_int_1           (scm_tc2_int + 0)
-#define scm_tc3_unused          3
+#define scm_tc3_aligned_pointer  3
 #define scm_tc3_imm24           4
 #define scm_tc3_tc7_1           5
 #define scm_tc3_int_2           (scm_tc2_int + 4)
-- 
1.7.3.2