[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-5-204-gfe
|
From: |
Ludovic Courtès |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-5-204-gfe258c4 |
|
Date: |
Fri, 11 Dec 2009 13:19:58 +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=fe258c43a179805a03e11e39025ea07c23b0d9a9
The branch, master has been updated
via fe258c43a179805a03e11e39025ea07c23b0d9a9 (commit)
via 09a8dc97dbb86d868e70605038983e7ce58061d0 (commit)
via f680bdd762f164ead068dcc53d14b7bd77f797b8 (commit)
via bd91ecce14c8df1022d4f7225888906541556570 (commit)
from 6c20a0b34b3c79c999213320eabf3d46eddd1c6e (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 fe258c43a179805a03e11e39025ea07c23b0d9a9
Author: Ludovic Courtès <address@hidden>
Date: Sun Dec 6 23:15:18 2009 +0100
SRFI-9: Make accessors inlinable.
* module/srfi/srfi-9.scm (define-inlinable): New macro.
(define-record-type): Use it.
commit 09a8dc97dbb86d868e70605038983e7ce58061d0
Author: Ludovic Courtès <address@hidden>
Date: Sun Dec 6 01:00:04 2009 +0100
SRFI-9: Reimplement in terms of structs, using `syntax-case'.
* module/srfi/srfi-9.scm (define-record-type): Rewrite to use raw
structs instead of records. Use `syntax-case' instead of
`define-macro'.
commit f680bdd762f164ead068dcc53d14b7bd77f797b8
Author: Ludovic Courtès <address@hidden>
Date: Fri Dec 11 12:58:06 2009 +0100
Add struct & vector benchmarks.
* benchmark-suite/benchmarks/structs.bm,
benchmark-suite/benchmarks/vectors.bm: New files.
* benchmark-suite/Makefile.am (SCM_BENCHMARKS): Add.
* benchmark-suite/benchmarks/bytevectors.bm: Fix copyright.
commit bd91ecce14c8df1022d4f7225888906541556570
Author: Ludovic Courtès <address@hidden>
Date: Fri Dec 11 12:44:29 2009 +0100
Add opcodes for `struct?', `struct-vtable', and `make-struct'.
* libguile/vm-engine.c (VM_NAME)[vm_error_not_a_struct]: New label.
* libguile/vm-i-scheme.c (VM_VALIDATE_STRUCT): New macro.
(struct_p, struct_vtable, make_struct): New instructions.
* module/language/tree-il/compile-glil.scm (*primcall-ops*): Add
`struct?', `struct-vtable', and `make-struct'.
* module/language/tree-il/primitives.scm (*interesting-primitive-names*,
*effect-free-primitives*): Likewise.
-----------------------------------------------------------------------
Summary of changes:
benchmark-suite/Makefile.am | 4 +-
benchmark-suite/benchmarks/bytevectors.bm | 5 +-
benchmark-suite/benchmarks/structs.bm | 68 +++++++++
.../benchmarks/{chars.bm => vectors.bm} | 54 +++----
libguile/vm-engine.c | 6 +
libguile/vm-i-scheme.c | 34 +++++
module/language/tree-il/compile-glil.scm | 3 +
module/language/tree-il/primitives.scm | 3 +
module/srfi/srfi-9.scm | 150 ++++++++++++++++----
9 files changed, 267 insertions(+), 60 deletions(-)
create mode 100644 benchmark-suite/benchmarks/structs.bm
copy benchmark-suite/benchmarks/{chars.bm => vectors.bm} (54%)
diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am
index dc35ed9..a9da00e 100644
--- a/benchmark-suite/Makefile.am
+++ b/benchmark-suite/Makefile.am
@@ -4,8 +4,10 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \
benchmarks/if.bm \
benchmarks/logand.bm \
benchmarks/read.bm \
+ benchmarks/structs.bm \
benchmarks/subr.bm \
- benchmarks/uniform-vector-read.bm
+ benchmarks/uniform-vector-read.bm \
+ benchmarks/vectors.bm
EXTRA_DIST = guile-benchmark lib.scm $(SCM_BENCHMARKS) \
ChangeLog-2008
diff --git a/benchmark-suite/benchmarks/bytevectors.bm
b/benchmark-suite/benchmarks/bytevectors.bm
index 06f23ef..66c88aa 100644
--- a/benchmark-suite/benchmarks/bytevectors.bm
+++ b/benchmark-suite/benchmarks/bytevectors.bm
@@ -1,8 +1,7 @@
-;;; coding: latin1 -*- mode: scheme; coding: latin-1; -*-
+;;; -*- mode: scheme; coding: iso-8859-1; -*-
;;; R6RS Byte Vectors.
;;;
-;;; Copyright 2009 Ludovic Courtès <address@hidden>
-;;;
+;;; Copyright 2009 Free Software Foundation, Inc.
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
diff --git a/benchmark-suite/benchmarks/structs.bm
b/benchmark-suite/benchmarks/structs.bm
new file mode 100644
index 0000000..65c8e97
--- /dev/null
+++ b/benchmark-suite/benchmarks/structs.bm
@@ -0,0 +1,68 @@
+;;; -*- mode: scheme; coding: iso-8859-1; -*-
+;;; Structs.
+;;;
+;;; Copyright 2009 Free Software Foundation, Inc.
+;;;
+;;; This program 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, or
+;;; (at your option) any later version.
+;;;
+;;; This program 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 software; see the file COPYING.LESSER. If
+;;; not, write to the Free Software Foundation, Inc., 51 Franklin
+;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (benchmarks structs)
+ :use-module (benchmark-suite lib))
+
+;; Note: Use `--iteration-factor' to change this.
+(define iterations 2000000)
+
+(define vtable2
+ (make-vtable "prpr"))
+
+(define vtable7
+ (make-vtable (string-concatenate (make-list 7 "pr"))))
+
+
+(with-benchmark-prefix "constructors"
+
+ (benchmark "make-struct2 (opcode)" iterations
+ (make-struct vtable2 0 1 2))
+
+ (benchmark "make-struct2 (procedure)" iterations
+ (let ((s make-struct))
+ (s vtable2 0 1 2)))
+
+ (benchmark "make-struct7 (opcode)" iterations
+ (make-struct vtable7 0 1 2 3 4 5 6 7))
+
+ (benchmark "make-struct7 (procedure)" iterations
+ (let ((s make-struct))
+ (s vtable7 0 1 2 3 4 5 6 7))))
+
+
+(with-benchmark-prefix "pairs" ;; for comparison
+
+ (benchmark "cons (opcode)" iterations
+ (cons 1 2))
+
+ (benchmark "cons (procedure)" iterations
+ (let ((c cons))
+ (c 1 2)))
+
+ (benchmark "list (opcode)" iterations
+ (list 1 2 3 4 5 6 7))
+
+ (benchmark "list (procedure)" iterations
+ (let ((l list))
+ (l 1 2 3 4 5 6 7)))
+
+ (benchmark "make-list" iterations
+ (make-list 7)))
diff --git a/benchmark-suite/benchmarks/chars.bm
b/benchmark-suite/benchmarks/vectors.bm
similarity index 54%
copy from benchmark-suite/benchmarks/chars.bm
copy to benchmark-suite/benchmarks/vectors.bm
index 6ae0e60..4e47e00 100644
--- a/benchmark-suite/benchmarks/chars.bm
+++ b/benchmark-suite/benchmarks/vectors.bm
@@ -1,8 +1,7 @@
-;;; coding: latin1 -*- mode: scheme; coding: latin-1; -*-
-;;; chars.bm
-;;;
-;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;; -*- mode: scheme; coding: iso-8859-1; -*-
+;;; Vectors.
;;;
+;;; Copyright 2009 Free Software Foundation, Inc.
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
@@ -19,39 +18,34 @@
;;; not, write to the Free Software Foundation, Inc., 51 Franklin
;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
-(define-module (benchmarks chars)
+(define-module (benchmarks vectors)
:use-module (benchmark-suite lib))
-
-(with-benchmark-prefix "chars"
-
- (benchmark "char" 1000000
- #\a)
-
- (benchmark "octal" 1000000
- #\123)
+;; Note: Use `--iteration-factor' to change this.
+(define iterations 1000000)
- (benchmark "char? eq" 1000000
- (char? #\a))
-
- (benchmark "char=?" 1000000
- (char=? #\a #\a))
+
+(with-benchmark-prefix "constructors"
- (benchmark "char<?" 1000000
- (char=? #\a #\a))
+ (benchmark "vector (opcode)" iterations
+ (vector 1 2 3 4 5 6 7))
- (benchmark "char-ci=?" 1000000
- (char=? #\a #\a))
+ (benchmark "vector (procedure)" iterations
+ (let ((v vector))
+ (v 1 2 3 4 5 6 7)))
- (benchmark "char-ci<? " 1000000
- (char=? #\a #\a))
+ (benchmark "make-vector" iterations
+ (make-vector 7)))
- (benchmark "char->integer" 1000000
- (char->integer #\a))
+
+(with-benchmark-prefix "pairs" ;; for comparison
- (benchmark "char-alphabetic?" 1000000
- (char-upcase #\a))
+ (benchmark "list (opcode)" iterations
+ (list 1 2 3 4 5 6 7))
- (benchmark "char-numeric?" 1000000
- (char-upcase #\a)))
+ (benchmark "list (procedure)" iterations
+ (let ((l list))
+ (l 1 2 3 4 5 6 7)))
+ (benchmark "make-list" iterations
+ (make-list 7)))
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 7fbb774..71cb636 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -206,6 +206,12 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int
nargs)
/* shouldn't get here */
goto vm_error;
+ vm_error_not_a_struct:
+ SYNC_ALL ();
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, finish_args, "struct");
+ /* shouldn't get here */
+ goto vm_error;
+
vm_error_no_values:
err_msg = scm_from_locale_string ("Zero values returned to single-valued
continuation");
finish_args = SCM_EOL;
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index c9b40ee..6faab9b 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -621,6 +621,40 @@ BV_FLOAT_SET (f64, ieee_double, double, 8)
#undef BV_INT_SET
#undef BV_FLOAT_SET
+#define VM_VALIDATE_STRUCT(obj) \
+ if (SCM_UNLIKELY (!SCM_STRUCTP (obj))) \
+ { \
+ finish_args = (obj); \
+ goto vm_error_not_a_struct; \
+ }
+
+VM_DEFINE_FUNCTION (174, struct_p, "struct?", 1)
+{
+ ARGS1 (obj);
+ RETURN (scm_from_bool (SCM_STRUCTP (obj)));
+}
+
+VM_DEFINE_FUNCTION (175, struct_vtable, "struct-vtable", 1)
+{
+ ARGS1 (obj);
+ VM_VALIDATE_STRUCT (obj);
+ RETURN (SCM_STRUCT_VTABLE (obj));
+}
+
+VM_DEFINE_INSTRUCTION (176, make_struct, "make-struct", 2, -1, 1)
+{
+ unsigned h = FETCH ();
+ unsigned l = FETCH ();
+ int n_args = ((h << 8U) + l);
+ SCM vtable = sp[1 - n_args], n_tail = sp[2 - n_args];
+ const SCM *inits = sp - n_args + 3;
+
+ sp -= n_args - 1;
+
+ RETURN (scm_c_make_structv (vtable, scm_to_size_t (n_tail),
+ n_args - 2, (scm_t_bits *) inits));
+}
+
/*
(defun renumber-ops ()
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index f0989a5..c0dae64 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -115,6 +115,9 @@
((variable-ref . 1) . variable-ref)
;; nb, *not* variable-set! -- the args are switched
((variable-set . 2) . variable-set)
+ ((struct? . 1) . struct?)
+ ((struct-vtable . 1) . struct-vtable)
+ (make-struct . make-struct)
;; hack for javascript
((return . 1) return)
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index a8767ae..bfe9af5 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -57,6 +57,8 @@
variable-ref variable-set!
;; args of variable-set are switched; it needs special help
+ struct? struct-vtable make-struct
+
bytevector-u8-ref bytevector-u8-set!
bytevector-s8-ref bytevector-s8-set!
@@ -104,6 +106,7 @@
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
vector-ref
+ struct? struct-vtable make-struct
bytevector-u8-ref bytevector-s8-ref
bytevector-u16-ref bytevector-u16-native-ref
bytevector-s16-ref bytevector-s16-native-ref
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index c64be5e..bd7dae8 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -1,6 +1,6 @@
;;; srfi-9.scm --- define-record-type
-;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2006, 2009 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
@@ -59,33 +59,131 @@
;;; Code:
(define-module (srfi srfi-9)
- :export-syntax (define-record-type))
+ #:use-module (srfi srfi-1)
+ #:export (define-record-type))
(cond-expand-provide (current-module) '(srfi-9))
-(define-macro (define-record-type type-name constructor/field-tag
- predicate-name . field-specs)
- `(begin
- (define ,type-name
- (make-record-type ',type-name ',(map car field-specs)))
- (define ,(car constructor/field-tag)
- (record-constructor ,type-name ',(cdr constructor/field-tag)))
- (define ,predicate-name
- (record-predicate ,type-name))
- ,@(map
- (lambda (spec)
- (cond
- ((= (length spec) 2)
- `(define ,(cadr spec)
- (record-accessor ,type-name ',(car spec))))
- ((= (length spec) 3)
- `(begin
- (define ,(cadr spec)
- (record-accessor ,type-name ',(car spec)))
- (define ,(caddr spec)
- (record-modifier ,type-name ',(car spec)))))
- (else
- (error "invalid field spec " spec))))
- field-specs)))
+(define-syntax define-inlinable
+ ;; Define a macro and a procedure such that direct calls are inlined, via
+ ;; the macro expansion, whereas references in non-call contexts refer to
+ ;; the procedure. Inspired by the `define-integrable' macro by Dybvig et al.
+ (lambda (x)
+ (define (make-procedure-name name)
+ (datum->syntax name
+ (symbol-append '% (syntax->datum name)
+ '-procedure)))
+
+ (syntax-case x ()
+ ((_ (name formals ...) body ...)
+ (identifier? #'name)
+ (with-syntax ((proc-name (make-procedure-name #'name)))
+ #`(begin
+ (define (proc-name formals ...)
+ body ...)
+ proc-name ;; unused
+ (define-syntax name
+ (lambda (x)
+ (syntax-case x ()
+ ((_ formals ...)
+ #'(begin body ...))
+ (_
+ #'proc-name))))))))))
+
+(define-syntax define-record-type
+ (lambda (x)
+ (define (field-identifiers field-specs)
+ (syntax-case field-specs ()
+ ((field-spec)
+ (syntax-case #'field-spec ()
+ ((name accessor) #'(name))
+ ((name accessor modifier) #'(name))))
+ ((field-spec rest ...)
+ (append (field-identifiers #'(field-spec))
+ (field-identifiers #'(rest ...))))))
+
+ (define (field-indices fields)
+ (fold (lambda (field result)
+ (let ((i (if (null? result)
+ 0
+ (+ 1 (cdar result)))))
+ (alist-cons field i result)))
+ '()
+ fields))
+
+ (define (constructor type-name constructor-spec indices)
+ (syntax-case constructor-spec ()
+ ((ctor field ...)
+ (let ((field-count (length indices))
+ (ctor-args (map (lambda (field)
+ (cons (syntax->datum field) field))
+ #'(field ...))))
+ #`(define #,constructor-spec
+ (make-struct #,type-name 0
+ #,@(unfold
+ (lambda (field-num)
+ (>= field-num field-count))
+ (lambda (field-num)
+ (let* ((name
+ (car (find (lambda (f+i)
+ (= (cdr f+i) field-num))
+ indices)))
+ (arg (assq name ctor-args)))
+ (if (pair? arg)
+ (cdr arg)
+ #'#f)))
+ 1+
+ 0)))))))
+
+ (define (accessors type-name field-specs indices)
+ (syntax-case field-specs ()
+ ((field-spec)
+ (syntax-case #'field-spec ()
+ ((name accessor)
+ (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
+ #`((define-inlinable (accessor s)
+ (if (eq? (struct-vtable s) #,type-name)
+ (struct-ref s index)
+ (throw 'wrong-type-arg 'accessor
+ "Wrong type argument: ~S" (list s)
+ (list s)))))))
+ ((name accessor modifier)
+ (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
+ #`(#,@(accessors type-name #'((name accessor)) indices)
+ (define-inlinable (modifier s val)
+ (if (eq? (struct-vtable s) #,type-name)
+ (struct-set! s index val)
+ (throw 'wrong-type-arg 'modifier
+ "Wrong type argument: ~S" (list s)
+ (list s)))))))))
+ ((field-spec rest ...)
+ #`(#,@(accessors type-name #'(field-spec) indices)
+ #,@(accessors type-name #'(rest ...) indices)))))
+
+ (syntax-case x ()
+ ((_ type-name constructor-spec predicate-name field-spec ...)
+ (let* ((fields (field-identifiers #'(field-spec ...)))
+ (field-count (length fields))
+ (layout (string-concatenate (make-list field-count "pw")))
+ (indices (field-indices (map syntax->datum fields))))
+ #`(begin
+ (define type-name
+ (make-vtable #,layout
+ (lambda (obj port)
+ (format port "#<~A" 'type-name)
+ #,@(map (lambda (field)
+ (let* ((f (syntax->datum field))
+ (i (assoc-ref indices f)))
+ #`(format port " ~A: ~S" '#,field
+ (struct-ref obj #,i))))
+ fields)
+ (format port ">"))))
+ (define-inlinable (predicate-name obj)
+ (and (struct? obj)
+ (eq? (struct-vtable obj) type-name)))
+
+ #,(constructor #'type-name #'constructor-spec indices)
+
+ #,@(accessors #'type-name #'(field-spec ...) indices)))))))
;;; srfi-9.scm ends here
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-5-204-gfe258c4,
Ludovic Courtès <=