Add nameset to name fibers and schedulers

* fibers/nameset.scm: New file.
* Makefile.am (SOURCES): Add new file.

2 files changed, 74 insertions, 0 deletions

diff --git a/Makefile.am b/Makefile.am
index 98eb069..3256a36 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -30,6 +30,7 @@ SOURCES = \
 	fibers/epoll.scm \
 	fibers/internal.scm \
 	fibers/psq.scm \
+	fibers/nameset.scm \
 	web/server/fibers.scm
 
 extlibdir = $(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/extensions
diff --git a/fibers/nameset.scm b/fibers/nameset.scm
new file mode 100644
index 0000000..525151f
--- /dev/null
+++ b/fibers/nameset.scm
@@ -0,0 +1,73 @@
+;; Fibers: cooperative, event-driven user-space threads.
+
+;;;; Copyright (C) 2016 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
+;;;;
+
+(define-module (fibers nameset)
+  #:use-module (ice-9 atomic)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:export ((make-nameset/public . make-nameset)
+            nameset-add!
+            nameset-fold))
+
+(define-syntax struct
+  (lambda (stx)
+    (define (id-append ctx . ids)
+      (datum->syntax ctx (apply symbol-append (map syntax->datum ids))))
+    (syntax-case stx ()
+      ((struct tag (field ...))
+       (with-syntax ((make-tag (id-append #'tag #'make- #'tag))
+                     (tag? (id-append #'tag #'tag #'?))
+                     ((tag-field ...) (map (cut id-append #'tag #'tag #'- <>)
+                                           #'(field ...))))
+         #'(define-record-type tag
+             (make-tag field ...)
+             tag?
+             (field tag-field)
+             ...))))))
+
+(struct nameset (names counter))
+
+(define (make-nameset/public)
+  "Create a fresh nameset, a weak collection of objects named by
+incrementing integers."
+  (make-nameset (make-weak-value-hash-table) (make-atomic-box 0)))
+
+(define (atomic-box-fetch-and-inc! box)
+  (let lp ((cur (atomic-box-ref box)))
+    (let* ((next (1+ cur))
+           (cur* (atomic-box-compare-and-swap! box cur next)))
+      (if (eqv? cur cur*)
+          cur
+          (lp cur*)))))
+
+(define (nameset-add! ns obj)
+  "Add @var{obj} to the nameset @var{ns}, and return the fresh
+name that was created."
+  (let ((name (atomic-box-fetch-and-inc! (nameset-counter ns))))
+    (hashv-set! (nameset-names ns) name obj)
+    name))
+
+(define* (nameset-fold f ns seed)
+  "Fold @var{f} over the objects contained in the nameset @var{ns}.
+This will call @var{f} as @code{(@var{f} @var{name} @var{obj}
+@var{seed})}, for each @var{name} and @var{obj} in the nameset,
+passing the result as @var{seed} to the next call and ultimately
+returning the final @var{seed} value."
+  (hash-fold f seed (nameset-names ns)))