guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-76-gbe05b3


From: Mark H Weaver
Subject: [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-76-gbe05b33
Date: Sat, 10 Nov 2012 15:08:27 +0000

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=be05b336090598ee306d5799926b66c7556a8a5d

The branch, stable-2.0 has been updated
       via  be05b336090598ee306d5799926b66c7556a8a5d (commit)
       via  92fac8c056f8c2e61852625d48b5f7a8e66b72b9 (commit)
      from  f31a0762328b9cffa328ce1540ceaa6f1497e083 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit be05b336090598ee306d5799926b66c7556a8a5d
Author: Mark H Weaver <address@hidden>
Date:   Wed Nov 7 08:39:42 2012 -0500

    Futures: Avoid creating the worker pool more than once.
    
    * module/ice-9/futures.scm (%create-workers!): Use 'with-mutex' in case
      an exception is thrown.  Within the critical section, check to make
      sure the worker pool hasn't already been created by another thread.

commit 92fac8c056f8c2e61852625d48b5f7a8e66b72b9
Author: Mark H Weaver <address@hidden>
Date:   Fri Nov 9 05:04:13 2012 -0500

    Improve error for set-fields paths leading to different types.
    
    * module/system/base/ck.scm: New module.
    
    * module/srfi/srfi-9.scm: Import (system base ck).
    
      (getter-type, getter-index, getter-copier): Convert incoming argument
      convention to CK form.
    
      (define-tagged-inlinable): Convert return value convention for key
      lookup to CK form.
    
    * module/srfi/srfi-9/gnu.scm: Import (system base ck).
      Rename '%set-fields-unknown-getter' to 'unknown-getter'.
    
      (c-list, c-same-type-check): New macros.
    
      (%set-fields): Using the CK abstract machine, arrange to check (at
      macro expansion time) that all of the getters in head position
      correspond to the same record type.
    
    * test-suite/tests/srfi-9.test: Add test.

-----------------------------------------------------------------------

Summary of changes:
 module/ice-9/futures.scm     |   24 ++++++++-----
 module/srfi/srfi-9.scm       |   21 +++++++----
 module/srfi/srfi-9/gnu.scm   |   78 +++++++++++++++++++++++++++++++----------
 module/system/base/ck.scm    |   55 +++++++++++++++++++++++++++++
 test-suite/tests/srfi-9.test |   36 +++++++++++++++++++
 5 files changed, 179 insertions(+), 35 deletions(-)
 create mode 100644 module/system/base/ck.scm

diff --git a/module/ice-9/futures.scm b/module/ice-9/futures.scm
index 0f64b5c..7fbccf6 100644
--- a/module/ice-9/futures.scm
+++ b/module/ice-9/futures.scm
@@ -19,6 +19,7 @@
 (define-module (ice-9 futures)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (ice-9 threads)
   #:use-module (ice-9 q)
   #:export (future make-future future? touch))
 
@@ -157,15 +158,20 @@ touched."
 (define %workers '())
 
 (define (%create-workers!)
-  (lock-mutex %futures-mutex)
-  (set! %workers
-        (unfold (lambda (i) (>= i %worker-count))
-                (lambda (i)
-                  (call-with-new-thread process-futures))
-                1+
-                0))
-  (set! create-workers! (lambda () #t))
-  (unlock-mutex %futures-mutex))
+  (with-mutex
+   %futures-mutex
+   ;; Setting 'create-workers!' to a no-op is an optimization, but it is
+   ;; still possible for '%create-workers!' to be called more than once
+   ;; from different threads.  Therefore, to avoid creating %workers more
+   ;; than once (and thus creating too many threads), we check to make
+   ;; sure %workers is empty within the critical section.
+   (when (null? %workers)
+     (set! %workers
+           (unfold (lambda (i) (>= i %worker-count))
+                   (lambda (i) (call-with-new-thread process-futures))
+                   1+
+                   0))
+     (set! create-workers! (lambda () #t)))))
 
 (define create-workers!
   (lambda () (%create-workers!)))
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index de49459..d213a86 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -60,6 +60,7 @@
 
 (define-module (srfi srfi-9)
   #:use-module (srfi srfi-1)
+  #:use-module (system base ck)
   #:export (define-record-type))
 
 (cond-expand-provide (current-module) '(srfi-9))
@@ -81,16 +82,22 @@
 (define-syntax-rule (%%on-error err) err)
 
 (define %%type #f)   ; a private syntax literal
-(define-syntax-rule (getter-type getter err)
-  (getter (%%on-error err) %%type))
+(define-syntax getter-type
+  (syntax-rules (quote)
+    ((_ s 'getter 'err)
+     (getter (%%on-error err) %%type s))))
 
 (define %%index #f)  ; a private syntax literal
-(define-syntax-rule (getter-index getter err)
-  (getter (%%on-error err) %%index))
+(define-syntax getter-index
+  (syntax-rules (quote)
+   ((_ s 'getter 'err)
+    (getter (%%on-error err) %%index s))))
 
 (define %%copier #f) ; a private syntax literal
-(define-syntax-rule (getter-copier getter err)
-  (getter (%%on-error err) %%copier))
+(define-syntax getter-copier
+  (syntax-rules (quote)
+   ((_ s 'getter 'err)
+    (getter (%%on-error err) %%copier s))))
 
 (define-syntax define-tagged-inlinable
   (lambda (x)
@@ -110,7 +117,7 @@
              (define-syntax name
                (lambda (x)
                  (syntax-case x (%%on-error key ...)
-                   ((_ (%%on-error err) key) #'value) ...
+                   ((_ (%%on-error err) key s) #'(ck s 'value)) ...
                    ((_ args ...)
                     #'((lambda (formals ...)
                          body ...)
diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm
index 4f3a663..6322756 100644
--- a/module/srfi/srfi-9/gnu.scm
+++ b/module/srfi/srfi-9/gnu.scm
@@ -24,6 +24,7 @@
 
 (define-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-1)
+  #:use-module (system base ck)
   #:export (set-record-type-printer!
             define-immutable-record-type
             set-field
@@ -76,12 +77,41 @@
   (with-syntax (((((head . tail) expr) ...) specs))
     (fold insert '() #'(head ...) #'(tail ...) #'(expr ...))))
 
-(define-syntax %set-fields-unknown-getter
+(define-syntax unknown-getter
   (lambda (x)
     (syntax-case x ()
       ((_ orig-form getter)
        (syntax-violation 'set-fields "unknown getter" #'orig-form #'getter)))))
 
+(define-syntax c-list
+  (lambda (x)
+    (syntax-case x (quote)
+      ((_ s 'v ...)
+       #'(ck s '(v ...))))))
+
+(define-syntax c-same-type-check
+  (lambda (x)
+    (syntax-case x (quote)
+      ((_ s 'orig-form '(path ...)
+          '(getter0 getter ...)
+          '(type0 type ...)
+          'on-success)
+       (every (lambda (t g)
+                (or (free-identifier=? t #'type0)
+                    (syntax-violation
+                     'set-fields
+                     (format #f
+                             "\
+field paths ~a and ~a require one object to belong to two different record 
types (~a and ~a)"
+                             (syntax->datum #`(path ... #,g))
+                             (syntax->datum #'(path ... getter0))
+                             (syntax->datum t)
+                             (syntax->datum #'type0))
+                     #'orig-form)))
+              #'(type ...)
+              #'(getter ...))
+       #'(ck s 'on-success)))))
+
 (define-syntax %set-fields
   (lambda (x)
     (with-syntax ((getter-type   #'(@@ (srfi srfi-9) getter-type))
@@ -98,24 +128,34 @@
             struct-expr ((head . tail) expr) ...)
          (let ((collated-specs (collate-set-field-specs
                                 #'(((head . tail) expr) ...))))
-           (with-syntax ((getter (caar collated-specs)))
-             (with-syntax ((err #'(%set-fields-unknown-getter
-                                   orig-form getter)))
-               #`(let ((s struct-expr))
-                   ((getter-copier getter err)
-                    check?
-                    s
-                    #,@(map (lambda (spec)
-                              (with-syntax (((head (tail expr) ...) spec))
-                                (with-syntax ((err 
#'(%set-fields-unknown-getter
-                                                      orig-form head)))
-                                 #'(head (%set-fields
-                                          check?
-                                          orig-form
-                                          (path-so-far ... head)
-                                          (struct-ref s (getter-index head 
err))
-                                          (tail expr) ...)))))
-                            collated-specs)))))))
+           (with-syntax (((getter0 getter ...)
+                          (map car collated-specs)))
+             (with-syntax ((err #'(unknown-getter
+                                   orig-form getter0)))
+               #`(ck
+                  ()
+                  (c-same-type-check
+                   'orig-form
+                   '(path-so-far ...)
+                   '(getter0 getter ...)
+                   (c-list (getter-type 'getter0 'err)
+                           (getter-type 'getter 'err) ...)
+                   '(let ((s struct-expr))
+                      ((ck () (getter-copier 'getter0 'err))
+                       check?
+                       s
+                       #,@(map (lambda (spec)
+                                 (with-syntax (((head (tail expr) ...) spec))
+                                   (with-syntax ((err #'(unknown-getter
+                                                         orig-form head)))
+                                     #'(head (%set-fields
+                                              check?
+                                              orig-form
+                                              (path-so-far ... head)
+                                              (struct-ref s (ck () 
(getter-index
+                                                                    'head 
'err)))
+                                              (tail expr) ...)))))
+                               collated-specs)))))))))
         ((_ check? orig-form (path-so-far ...)
             s (() e) (() e*) ...)
          (syntax-violation 'set-fields "duplicate field path"
diff --git a/module/system/base/ck.scm b/module/system/base/ck.scm
new file mode 100644
index 0000000..cd9cc18
--- /dev/null
+++ b/module/system/base/ck.scm
@@ -0,0 +1,55 @@
+;;; ck, to facilitate applicative-order macro programming
+
+;;; Copyright (C) 2012 Free Software Foundation, Inc
+;;; Copyright (C) 2009, 2011 Oleg Kiselyov
+;;;
+;;; 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
+;;;
+;;;
+;;; Originally written by Oleg Kiselyov and later contributed to Guile.
+;;;
+;;; Based on the CK machine introduced in:
+;;;
+;;; Matthias Felleisen and Daniel P. Friedman: Control operators, the
+;;; SECD machine, and the lambda-calculus.  In Martin Wirsing, editor,
+;;; Formal Description of Programming Concepts III, pages
+;;; 193-217. Elsevier, Amsterdam, 1986.
+;;;
+;;; See http://okmij.org/ftp/Scheme/macros.html#ck-macros for details.
+;;;
+
+(define-module (system base ck)
+  #:export (ck))
+
+(define-syntax ck
+  (syntax-rules (quote)
+    ((ck () 'v) v)                      ; yield the value on empty stack
+
+    ((ck (((op ...) ea ...) . s) 'v)    ; re-focus on the other argument, ea
+     (ck-arg s (op ... 'v) ea ...))
+
+    ((ck s (op ea ...))                 ; Focus: handling an application;
+     (ck-arg s (op) ea ...))))          ; check if args are values
+
+(define-syntax ck-arg
+  (syntax-rules (quote)
+    ((ck-arg s (op va ...))             ; all arguments are evaluated,
+     (op s va ...))                     ; do the redex
+
+    ((ck-arg s (op ...) 'v ea1 ...)     ; optimization when the first ea
+     (ck-arg s (op ... 'v) ea1 ...))    ; was already a value
+
+    ((ck-arg s (op ...) ea ea1 ...)     ; focus on ea, to evaluate it
+     (ck (((op ...) ea1 ...) . s) ea))))
diff --git a/test-suite/tests/srfi-9.test b/test-suite/tests/srfi-9.test
index 4935148..cd313ac 100644
--- a/test-suite/tests/srfi-9.test
+++ b/test-suite/tests/srfi-9.test
@@ -608,6 +608,42 @@
                    #:env (current-module))
           #f)
         (lambda (key whom what src form subform)
+          (list key whom what form subform))))
+
+    (pass-if-equal "incompatible field paths"
+        '(syntax-error set-fields
+                       "\
+field paths (bar-i bar-j) and (bar-i foo-x) require one object \
+to belong to two different record types (:bar and foo)"
+                       (set-fields s
+                         ((bar-i foo-x) 1)
+                         ((bar-i bar-j) 2)
+                         ((bar-j) 3))
+                       #f)
+      (catch 'syntax-error
+        (lambda ()
+          (compile '(let ()
+                      (define-immutable-record-type foo
+                        (make-foo x)
+                        foo?
+                        (x foo-x)
+                        (y foo-y set-foo-y)
+                        (z foo-z set-foo-z))
+
+                      (define-immutable-record-type :bar
+                        (make-bar i j)
+                        bar?
+                        (i bar-i)
+                        (j bar-j set-bar-j))
+
+                      (let ((s (make-bar (make-foo 5) 2)))
+                        (set-fields s
+                          ((bar-i foo-x) 1)
+                          ((bar-i bar-j) 2)
+                          ((bar-j) 3))))
+                   #:env (current-module))
+          #f)
+        (lambda (key whom what src form subform)
           (list key whom what form subform))))))
 
 


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]