Add thread-local lock-free, TLS-free freelists.

* libguile/bdw-gc.h: Remove a needless compatibility hack.

* libguile/gc-inline.h: New file, implementing thread-local freelists
  providing faster allocation if we already have a scm_i_thread*
  pointer.  Based on gc_inline.h from libgc.

* libguile/threads.h (scm_i_thread): Add freelists here.
* libguile/threads.c (guilify_self_1, guilify_self_2): Initialize
  freelists.

* libguile/vm.c: Include gc-inline.h.
* libguile/vm-engine.c: Rename current_thread to thread.  Use
  scm_inline_cons instead of scm_cons, scm_inline_cell instead of
  scm_cell, and scm_inline_words instead of words.

7 files changed, 247 insertions, 30 deletions

diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 3f66d9d8d..2077c4dac 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -1,7 +1,7 @@
 ## Process this file with Automake to create Makefile.in
 ##
 ##   Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007,
-##     2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+##     2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
 ##
 ##   This file is part of GUILE.
 ##
@@ -558,6 +558,7 @@ modinclude_HEADERS =				\
 	fports.h				\
 	frames.h				\
 	gc.h					\
+	gc-inline.h				\
 	gettext.h				\
 	generalized-arrays.h			\
 	generalized-vectors.h			\
diff --git a/libguile/bdw-gc.h b/libguile/bdw-gc.h
index 7aa757fed..2deb97e94 100644
--- a/libguile/bdw-gc.h
+++ b/libguile/bdw-gc.h
@@ -1,7 +1,7 @@
 #ifndef SCM_BDW_GC_H
 #define SCM_BDW_GC_H
 
-/* Copyright (C) 2006, 2008, 2009, 2011, 2012, 2013 Free Software Foundation, Inc.
+/* Copyright (C) 2006, 2008, 2009, 2011, 2012, 2013, 2014 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
@@ -46,11 +46,6 @@
 
 #include <gc/gc.h>
 
-#if (! ((defined GC_VERSION_MAJOR) && (GC_VERSION_MAJOR >= 7)))
-/* This was needed with `libgc' 6.x.  */
-# include <gc/gc_local_alloc.h>
-#endif
-
 /* Return true if PTR points to the heap.  */
 #define SCM_I_IS_POINTER_TO_THE_HEAP(ptr)	\
   (GC_base (ptr) != NULL)
diff --git a/libguile/gc-inline.h b/libguile/gc-inline.h
new file mode 100644
index 000000000..fcbe5a54e
--- /dev/null
+++ b/libguile/gc-inline.h
@@ -0,0 +1,183 @@
+/* classes: h_files */
+
+#ifndef SCM_GC_INLINE_H
+#define SCM_GC_INLINE_H
+
+/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006,
+ *   2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 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
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+/* Much of this file was copied from gc_inline.h, from the BDW
+ * collector.  Its copyright notice is:
+ *
+ * Copyright 1988, 1989 Hans-J. Boehm, Alan J. Demers
+ * Copyright (c) 1991-1995 by Xerox Corporation.  All rights reserved.
+ * Copyright (c) 2005 Hewlett-Packard Development Company, L.P.
+ *
+ * THIS MATERIAL IS PROVIDED AS IS, WITH ABSOLUTELY NO WARRANTY EXPRESSED
+ * OR IMPLIED.  ANY USE IS AT YOUR OWN RISK.
+ *
+ * Permission is hereby granted to use or copy this program
+ * for any purpose,  provided the above notices are retained on all copies.
+ * Permission to modify the code and to distribute modified code is granted,
+ * provided the above notices are retained, and a notice that the code was
+ * modified is included with the above copyright notice.
+ */
+
+
+
+#include "libguile/__scm.h"
+
+#include "libguile/gc.h"
+#include "libguile/bdw-gc.h"
+#include "libguile/threads.h"
+
+#include <gc/gc_inline.h> /* GC_generic_malloc_many */
+
+
+
+#define SCM_INLINE_GC_GRANULE_WORDS 2
+#define SCM_INLINE_GC_GRANULE_BYTES \
+  (sizeof(void *) * SCM_INLINE_GC_GRANULE_WORDS)
+
+/* A freelist set contains SCM_INLINE_GC_FREELIST_COUNT pointers to
+   singly linked lists of objects of different sizes, the ith one
+   containing objects i + 1 granules in size.  This setting of
+   SCM_INLINE_GC_FREELIST_COUNT will hold freelists for allocations of
+   up to 256 bytes.  */
+#define SCM_INLINE_GC_FREELIST_COUNT (256U / SCM_INLINE_GC_GRANULE_BYTES)
+
+static inline size_t
+scm_inline_gc_bytes_to_freelist_index (size_t bytes)
+{
+  return (bytes - 1U) / SCM_INLINE_GC_GRANULE_BYTES;
+}
+
+static inline size_t
+scm_inline_gc_freelist_object_size (size_t idx)
+{
+  return (idx + 1U) * SCM_INLINE_GC_GRANULE_BYTES;
+}
+
+/* The values of these must match the internal POINTERLESS and NORMAL
+   definitions in libgc, for which unfortunately there are no external
+   definitions.  Alack.  */
+typedef enum scm_inline_gc_kind
+  {
+    SCM_INLINE_GC_KIND_POINTERLESS,
+    SCM_INLINE_GC_KIND_NORMAL
+  } scm_inline_gc_kind;
+
+static inline void *
+scm_inline_gc_alloc (void **freelist, size_t idx, scm_inline_gc_kind kind)
+{
+  void *head = *freelist;
+
+  if (SCM_UNLIKELY (!head))
+    {
+      size_t bytes = scm_inline_gc_freelist_object_size (idx);
+      GC_generic_malloc_many (bytes, kind, freelist);
+      head = *freelist;
+      if (SCM_UNLIKELY (!head))
+        return (*GC_get_oom_fn ()) (bytes);
+    }
+
+  *freelist = *(void **)(head);
+
+  return head;
+}
+
+static inline void *
+scm_inline_gc_malloc_pointerless (scm_i_thread *thread, size_t bytes)
+{
+  size_t idx = scm_inline_gc_bytes_to_freelist_index (bytes);
+
+  if (SCM_UNLIKELY (idx >= SCM_INLINE_GC_FREELIST_COUNT))
+    return GC_malloc_atomic (bytes);
+
+  return scm_inline_gc_alloc
+    (&thread->pointerless_freelists[idx], idx, SCM_INLINE_GC_KIND_POINTERLESS);
+}
+
+static inline void *
+scm_inline_gc_malloc (scm_i_thread *thread, size_t bytes)
+{
+  size_t idx = scm_inline_gc_bytes_to_freelist_index (bytes);
+
+  if (SCM_UNLIKELY (idx >= SCM_INLINE_GC_FREELIST_COUNT))
+    return GC_malloc (bytes);
+
+  return scm_inline_gc_alloc
+    (&thread->freelists[idx], idx, SCM_INLINE_GC_KIND_NORMAL);
+}
+
+static inline void *
+scm_inline_gc_malloc_words (scm_i_thread *thread, size_t words)
+{
+  return scm_inline_gc_malloc (thread, words * sizeof (void *));
+}
+
+static inline SCM
+scm_inline_cell (scm_i_thread *thread, scm_t_bits car, scm_t_bits cdr)
+{
+  SCM cell = SCM_PACK_POINTER (scm_inline_gc_malloc_words (thread, 2));
+  
+  SCM_GC_SET_CELL_WORD (cell, 0, car);
+  SCM_GC_SET_CELL_WORD (cell, 1, cdr);
+
+  return cell;
+}
+
+static inline SCM
+scm_inline_double_cell (scm_i_thread *thread, scm_t_bits car, scm_t_bits cbr,
+                           scm_t_bits ccr, scm_t_bits cdr)
+{
+  SCM cell = SCM_PACK_POINTER (scm_inline_gc_malloc_words (thread, 4));
+  
+  SCM_GC_SET_CELL_WORD (cell, 0, car);
+  SCM_GC_SET_CELL_WORD (cell, 1, cbr);
+  SCM_GC_SET_CELL_WORD (cell, 2, ccr);
+  SCM_GC_SET_CELL_WORD (cell, 3, cdr);
+
+  return cell;
+}
+
+static inline SCM
+scm_inline_words (scm_i_thread *thread, scm_t_bits car, scm_t_uint32 n_words)
+{
+  SCM obj = SCM_PACK_POINTER (scm_inline_gc_malloc_words (thread, n_words));
+  
+  SCM_GC_SET_CELL_WORD (obj, 0, car);
+
+  return obj;
+}
+
+static inline SCM
+scm_inline_cons (scm_i_thread *thread, SCM x, SCM y)
+{
+  return scm_inline_cell (thread, SCM_UNPACK (x), SCM_UNPACK (y));
+}
+
+
+#endif  /* SCM_GC_INLINE_H */
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/
diff --git a/libguile/threads.c b/libguile/threads.c
index f39bcc39e..7902a9a0d 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -1,5 +1,5 @@
 /* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004,
- *   2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
+ *   2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014
  *   Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -63,6 +63,7 @@
 #include "libguile/fluids.h"
 #include "libguile/continuations.h"
 #include "libguile/gc.h"
+#include "libguile/gc-inline.h"
 #include "libguile/init.h"
 #include "libguile/scmsigs.h"
 #include "libguile/strings.h"
@@ -95,6 +96,26 @@ thread_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr,
 				       mark_stack_ptr, mark_stack_limit,
 				       NULL);
 
+  /* The pointerless freelists are threaded through their first word,
+     but GC doesn't know to trace them (as they are pointerless), so we
+     need to do that here.  See the comments at the top of libgc's
+     gc_inline.h.  */
+  {
+    size_t n;
+    for (n = 0; n < SCM_INLINE_GC_FREELIST_COUNT; n++)
+      {
+        void *chain = t->pointerless_freelists[n];
+        if (chain)
+          {
+            /* The first link is already marked by the freelist vector,
+               so we just have to mark the tail.  */
+            while ((chain = *(void **)chain))
+              mark_stack_ptr = GC_mark_and_push (chain, mark_stack_ptr,
+                                                 mark_stack_limit, NULL);
+          }
+      }
+  }
+
   if (t->vp)
     mark_stack_ptr = scm_i_vm_mark_stack (t->vp, mark_stack_ptr,
                                           mark_stack_limit);
@@ -389,6 +410,8 @@ guilify_self_1 (struct GC_stack_base *base)
   t.mutexes = SCM_EOL;
   t.held_mutex = NULL;
   t.join_queue = SCM_EOL;
+  t.freelists = NULL;
+  t.pointerless_freelists = NULL;
   t.dynamic_state = SCM_BOOL_F;
   t.dynstack.base = NULL;
   t.dynstack.top = NULL;
@@ -459,6 +482,12 @@ guilify_self_2 (SCM parent)
   t->continuation_root = scm_cons (t->handle, SCM_EOL);
   t->continuation_base = t->base;
 
+  {
+    size_t size = SCM_INLINE_GC_FREELIST_COUNT * sizeof (void *);
+    t->freelists = scm_gc_malloc (size, "freelists");
+    t->pointerless_freelists = scm_gc_malloc (size, "atomic freelists");
+  }
+
   if (scm_is_true (parent))
     t->dynamic_state = scm_make_dynamic_state (parent);
   else
diff --git a/libguile/threads.h b/libguile/threads.h
index 6db6c7594..6b85baf52 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -4,7 +4,7 @@
 #define SCM_THREADS_H
 
 /* Copyright (C) 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2006,
- *   2007, 2008, 2009, 2011, 2012, 2013 Free Software Foundation, Inc.
+ *   2007, 2008, 2009, 2011, 2012, 2013, 2014 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
@@ -72,6 +72,10 @@ typedef struct scm_i_thread {
   scm_i_pthread_cond_t sleep_cond;
   int sleep_fd, sleep_pipe[2];
 
+  /* Thread-local freelists; see gc-inline.h.  */
+  void **freelists;
+  void **pointerless_freelists;
+
   /* Other thread local things.
    */
   SCM dynamic_state;
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index fe0329f54..bc94a6951 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -127,7 +127,7 @@
   RUN_HOOK0 (abort)
 
 #define VM_HANDLE_INTERRUPTS                     \
-  SCM_ASYNC_TICK_WITH_GUARD_CODE (current_thread, SYNC_IP (), CACHE_FP ())
+  SCM_ASYNC_TICK_WITH_GUARD_CODE (thread, SYNC_IP (), CACHE_FP ())
 
 
 /* Virtual Machine
@@ -430,7 +430,7 @@
   ((scm_t_uintptr) (ptr) % alignof_type (type) == 0)
 
 static SCM
-VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
+VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
          scm_i_jmp_buf *registers, int resume)
 {
   /* Instruction pointer: A pointer to the opcode that is currently
@@ -527,7 +527,7 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
           scm_t_uint32 n;
           ret = SCM_EOL;
           for (n = nvals; n > 0; n--)
-            ret = scm_cons (LOCAL_REF (4 + n - 1), ret);
+            ret = scm_inline_cons (thread, LOCAL_REF (4 + n - 1), ret);
           ret = scm_values (ret);
         }
 
@@ -810,7 +810,8 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
       SYNC_IP ();
 
       // FIXME: separate args
-      ret = scm_i_foreign_call (scm_cons (cif, pointer), LOCAL_ADDRESS (1));
+      ret = scm_i_foreign_call (scm_inline_cons (thread, cif, pointer),
+                                LOCAL_ADDRESS (1));
 
       CACHE_FP ();
 
@@ -872,7 +873,7 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
                  vm_error_continuation_not_rewindable (vmcont));
       vm_reinstate_partial_continuation (vp, vmcont, FRAME_LOCALS_COUNT_FROM (1),
                                          LOCAL_ADDRESS (1),
-                                         &current_thread->dynstack,
+                                         &thread->dynstack,
                                          registers);
       CACHE_REGISTER ();
       NEXT (0);
@@ -938,7 +939,7 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
       VM_HANDLE_INTERRUPTS;
 
       SYNC_IP ();
-      dynstack = scm_dynstack_capture_all (&current_thread->dynstack);
+      dynstack = scm_dynstack_capture_all (&thread->dynstack);
       vm_cont = scm_i_vm_capture_stack (vp->stack_base,
                                         SCM_FRAME_DYNAMIC_LINK (fp),
                                         SCM_FRAME_PREVIOUS_SP (fp),
@@ -1242,7 +1243,7 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
           SCM rest = SCM_EOL;
           n = nkw;
           while (n--)
-            rest = scm_cons (LOCAL_REF (ntotal + n), rest);
+            rest = scm_inline_cons (thread, LOCAL_REF (ntotal + n), rest);
           LOCAL_SET (nreq_and_opt, rest);
         }
 
@@ -1274,7 +1275,7 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
         {
           while (nargs-- > dst)
             {
-              rest = scm_cons (LOCAL_REF (nargs), rest);
+              rest = scm_inline_cons (thread, LOCAL_REF (nargs), rest);
               LOCAL_SET (nargs, SCM_UNDEFINED);
             }
 
@@ -1490,7 +1491,8 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
     {
       scm_t_uint16 dst, src;
       UNPACK_12_12 (op, dst, src);
-      LOCAL_SET (dst, scm_cell (scm_tc7_variable, SCM_UNPACK (LOCAL_REF (src))));
+      LOCAL_SET (dst, scm_inline_cell (thread, scm_tc7_variable,
+                                       SCM_UNPACK (LOCAL_REF (src))));
       NEXT (1);
     }
 
@@ -1547,7 +1549,8 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
       UNPACK_24 (ip[2], nfree);
 
       // FIXME: Assert range of nfree?
-      closure = scm_words (scm_tc7_program | (nfree << 16), nfree + 2);
+      closure = scm_inline_words (thread, scm_tc7_program | (nfree << 16),
+                                  nfree + 2);
       SCM_SET_CELL_WORD_1 (closure, ip + offset);
       // FIXME: Elide these initializations?
       for (n = 0; n < nfree; n++)
@@ -2002,7 +2005,7 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
   
       /* Push the prompt onto the dynamic stack. */
       flags = escape_only_p ? SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY : 0;
-      scm_dynstack_push_prompt (&current_thread->dynstack, flags,
+      scm_dynstack_push_prompt (&thread->dynstack, flags,
                                 LOCAL_REF (tag),
                                 fp - vp->stack_base,
                                 LOCAL_ADDRESS (proc_slot) - vp->stack_base,
@@ -2023,7 +2026,7 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
     {
       scm_t_uint16 winder, unwinder;
       UNPACK_12_12 (op, winder, unwinder);
-      scm_dynstack_push_dynwind (&current_thread->dynstack,
+      scm_dynstack_push_dynwind (&thread->dynstack,
                                  LOCAL_REF (winder), LOCAL_REF (unwinder));
       NEXT (1);
     }
@@ -2035,7 +2038,7 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
    */
   VM_DEFINE_OP (64, unwind, "unwind", OP1 (U8_X24))
     {
-      scm_dynstack_pop (&current_thread->dynstack);
+      scm_dynstack_pop (&thread->dynstack);
       NEXT (1);
     }
 
@@ -2049,9 +2052,9 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
 
       UNPACK_12_12 (op, fluid, value);
 
-      scm_dynstack_push_fluid (&current_thread->dynstack,
+      scm_dynstack_push_fluid (&thread->dynstack,
                                LOCAL_REF (fluid), LOCAL_REF (value),
-                               current_thread->dynamic_state);
+                               thread->dynamic_state);
       NEXT (1);
     }
 
@@ -2063,8 +2066,8 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
   VM_DEFINE_OP (66, pop_fluid, "pop-fluid", OP1 (U8_X24))
     {
       /* This function must not allocate.  */
-      scm_dynstack_unwind_fluid (&current_thread->dynstack,
-                                 current_thread->dynamic_state);
+      scm_dynstack_unwind_fluid (&thread->dynstack,
+                                 thread->dynamic_state);
       NEXT (1);
     }
 
@@ -2080,7 +2083,7 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
 
       UNPACK_12_12 (op, dst, src);
       fluid = LOCAL_REF (src);
-      fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
+      fluids = SCM_I_DYNAMIC_STATE_FLUIDS (thread->dynamic_state);
       if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
           || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
         {
@@ -2113,7 +2116,7 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
 
       UNPACK_12_12 (op, a, b);
       fluid = LOCAL_REF (a);
-      fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state);
+      fluids = SCM_I_DYNAMIC_STATE_FLUIDS (thread->dynamic_state);
       if (SCM_UNLIKELY (!SCM_FLUID_P (fluid))
           || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids)))
         {
@@ -2229,7 +2232,7 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
   VM_DEFINE_OP (74, cons, "cons", OP1 (U8_U8_U8_U8) | OP_DST)
     {
       ARGS2 (x, y);
-      RETURN (scm_cons (x, y));
+      RETURN (scm_inline_cons (thread, x, y));
     }
 
   /* car dst:12 src:12
@@ -2497,7 +2500,8 @@ VM_NAME (scm_i_thread *current_thread, struct scm_vm *vp,
       UNPACK_8_8_8 (op, dst, length, init);
 
       val = LOCAL_REF (init);
-      vector = scm_words (scm_tc7_vector | (length << 8), length + 1);
+      vector = scm_inline_words (thread, scm_tc7_vector | (length << 8),
+                                 length + 1);
       for (n = 0; n < length; n++)
         SCM_SIMPLE_VECTOR_SET (vector, n, val);
       LOCAL_SET (dst, vector);
diff --git a/libguile/vm.c b/libguile/vm.c
index a2d0ccc01..95f12ee86 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -40,6 +40,7 @@
 #include "_scm.h"
 #include "control.h"
 #include "frames.h"
+#include "gc-inline.h"
 #include "instructions.h"
 #include "loader.h"
 #include "programs.h"