From 927b96b48d4870c768da093741af6e6bcd438cad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 13 Jul 2010 00:07:12 +0200 Subject: [PATCH] Start rewriting SRFI-1 in Scheme. This partially reverts commit e556f8c3c6b74ee6596e8dcbe829109d7745da2c (Fri May 6 2005). * module/srfi/srfi-1.scm (xcons, list-tabulate, not-pair?, car+cdr, last, fold, list-index): New procedures. * srfi/srfi-1.c (srfi1_module): New variable. (CACHE_VAR): New macro. (scm_srfi1_car_plus_cdr, scm_srfi1_fold, scm_srfi1_last, scm_srfi1_list_index, scm_srfi1_list_tabulate, scm_srfi1_not_pair_p, scm_srfi1_xcons): Rewrite as proxies of the corresponding Scheme procedure. * test-suite/tests/srfi-1.test ("list-tabulate")["-1"]: Change exception type to `exception:wrong-type-arg'. * benchmark-suite/benchmarks/srfi-1.bm: New file. * benchmark-suite/Makefile.am (SCM_BENCHMARKS): Add `benchmarks/srfi-1.bm'. --- benchmark-suite/Makefile.am | 1 + benchmark-suite/benchmarks/srfi-1.bm | 38 ++++ module/srfi/srfi-1.scm | 64 +++++++- srfi/srfi-1.c | 318 ++++++---------------------------- test-suite/tests/srfi-1.test | 4 +- 5 files changed, 154 insertions(+), 271 deletions(-) create mode 100644 benchmark-suite/benchmarks/srfi-1.bm diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am index d99e457..b58219a 100644 --- a/benchmark-suite/Makefile.am +++ b/benchmark-suite/Makefile.am @@ -5,6 +5,7 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \ benchmarks/if.bm \ benchmarks/logand.bm \ benchmarks/read.bm \ + benchmarks/srfi-1.bm \ benchmarks/srfi-13.bm \ benchmarks/structs.bm \ benchmarks/subr.bm \ diff --git a/benchmark-suite/benchmarks/srfi-1.bm b/benchmark-suite/benchmarks/srfi-1.bm new file mode 100644 index 0000000..2888934 --- /dev/null +++ b/benchmark-suite/benchmarks/srfi-1.bm @@ -0,0 +1,38 @@ +;;; -*- mode: scheme; coding: utf-8; -*- +;;; SRFI-1. +;;; +;;; Copyright 2010 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 srfi-1) + #:use-module (srfi srfi-1) + #:use-module (benchmark-suite lib)) + +(define %big-list + (iota 1000000)) + +(define %small-list + (iota 10)) + + +(with-benchmark-prefix "fold" + + (benchmark "fold" 30 + (fold (lambda (x y) y) #f %big-list)) + + (benchmark "fold" 2000000 + (fold (lambda (x y) y) #f %small-list))) diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index c32eb1c..27aa39e 100644 --- a/module/srfi/srfi-1.scm +++ b/module/srfi/srfi-1.scm @@ -1,6 +1,6 @@ ;;; srfi-1.scm --- List Library -;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010 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 @@ -225,6 +225,11 @@ ;;; Constructors +(define (xcons d a) + "Like `cons', but with interchanged arguments. Useful mostly when passed to +higher-order procedures." + (cons a d)) + ;; internal helper, similar to (scsh utilities) check-arg. (define (check-arg-type pred arg caller) (if (pred arg) @@ -235,7 +240,15 @@ ;; the srfi spec doesn't seem to forbid inexact integers. (define (non-negative-integer? x) (and (integer? x) (>= x 0))) - +(define (list-tabulate n init-proc) + "Return an N-element list, where each list element is produced by applying the +procedure INIT-PROC to the corresponding list index. The order in which +INIT-PROC is applied to the indices is not specified." + (check-arg-type non-negative-integer? n "list-tabulate") + (let lp ((n n) (acc '())) + (if (<= n 0) + acc + (lp (- n 1) (cons (init-proc (- n 1)) acc))))) (define (circular-list elt1 . elts) (set! elts (cons elt1 elts)) @@ -294,6 +307,13 @@ (else (error "not a proper list in null-list?")))) +(define (not-pair? x) + "Return #t if X is not a pair, #f otherwise. + +This is shorthand notation `(not (pair? X))' and is supposed to be used for +end-of-list checking in contexts where dotted lists are allowed." + (not (pair? x))) + (define (list= elt= . rest) (define (lists-equal a b) (let lp ((a a) (b b)) @@ -317,9 +337,17 @@ (define third caddr) (define fourth cadddr) +(define (car+cdr x) + "Return two values, the `car' and the `cdr' of PAIR." + (values (car x) (cdr x))) + (define take list-head) (define drop list-tail) +(define (last pair) + "Return the last element of the non-empty, finite list PAIR." + (car (last-pair pair))) + ;;; Miscelleneous: length, append, concatenate, reverse, zip & count (define (zip clist1 . rest) @@ -343,6 +371,21 @@ ;;; Fold, unfold & map +(define (fold kons knil list1 . rest) + "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return +that result. See the manual for details." + (if (null? rest) + (let f ((knil knil) (list1 list1)) + (if (null? list1) + knil + (f (kons (car list1) knil) (cdr list1)))) + (let f ((knil knil) (lists (cons list1 rest))) + (if (any null? lists) + knil + (let ((cars (map1 car lists)) + (cdrs (map1 cdr lists))) + (f (apply kons (append! cars (list knil))) cdrs)))))) + (define (fold-right kons knil clist1 . rest) (if (null? rest) (let f ((list1 clist1)) @@ -463,6 +506,23 @@ (else (and (pred (car ls)) (lp (cdr ls))))))) +(define (list-index pred clist1 . rest) + "Return the index of the first set of elements, one from each of +CLIST1 ... CLISTN, that satisfies PRED." + (if (null? rest) + (let lp ((l clist1) (i 0)) + (if (null? l) + #f + (if (pred (car l)) + i + (lp (cdr l) (+ i 1))))) + (let lp ((lists (cons clist1 rest)) (i 0)) + (cond ((any1 null? lists) + #f) + ((apply pred (map1 car lists)) i) + (else + (lp (map1 cdr lists) (+ i 1))))))) + ;;; Association lists (define alist-cons acons) diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c index 537c2b3..71cfcf9 100644 --- a/srfi/srfi-1.c +++ b/srfi/srfi-1.c @@ -27,13 +27,32 @@ #include "srfi-1.h" -/* The intent of this file is to gradually replace those Scheme - * procedures in srfi-1.scm which extends core primitive procedures, +/* The intent of this file was to gradually replace those Scheme + * procedures in srfi-1.scm that extend core primitive procedures, * so that using srfi-1 won't have performance penalties. * - * Please feel free to contribute any new replacements! + * However, we now prefer to write these procedures in Scheme, let the compiler + * optimize them, and have the VM execute them efficiently. */ + +/* The `(srfi srfi-1)' module. */ +static SCM srfi1_module = SCM_BOOL_F; + +/* Cache variable NAME in C variable VAR. */ +#define CACHE_VAR(var, name) \ + static SCM var = SCM_BOOL_F; \ + if (scm_is_false (var)) \ + { \ + if (SCM_UNLIKELY (scm_is_false (srfi1_module))) \ + srfi1_module = scm_c_resolve_module ("srfi srfi-1"); \ + \ + var = scm_module_variable (srfi1_module, \ + scm_from_locale_symbol (name)); \ + if (scm_is_false (var)) \ + abort (); \ + } + static long srfi1_ilength (SCM sx) { @@ -253,16 +272,12 @@ SCM_DEFINE (scm_srfi1_break_x, "break!", 2, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_srfi1_car_plus_cdr, "car+cdr", 1, 0, 0, - (SCM pair), - "Return two values, the @sc{car} and the @sc{cdr} of @var{pair}.") -#define FUNC_NAME s_scm_srfi1_car_plus_cdr +SCM +scm_srfi1_car_plus_cdr (SCM pair) { - SCM_VALIDATE_CONS (SCM_ARG1, pair); - return scm_values (scm_list_2 (SCM_CAR (pair), SCM_CDR (pair))); + CACHE_VAR (car_plus_cdr, "car+cdr"); + return scm_call_1 (car_plus_cdr, pair); } -#undef FUNC_NAME - SCM_DEFINE (scm_srfi1_concatenate, "concatenate", 1, 0, 0, (SCM lstlst), @@ -935,131 +950,19 @@ SCM_DEFINE (scm_srfi1_find_tail, "find-tail", 2, 0, 0, } #undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_fold, "fold", 3, 0, 1, - (SCM proc, SCM init, SCM list1, SCM rest), - "Apply @var{proc} to the elements of @var{lst1} @dots{}\n" - "@var{lstN} to build a result, and return that result.\n" - "\n" - "Each @var{proc} call is @code{(@var{proc} @var{elem1} @dots{}\n" - "@var{elemN} @var{previous})}, where @var{elem1} is from\n" - "@var{lst1}, through @var{elemN} from @var{lstN}.\n" - "@var{previous} is the return from the previous call to\n" - "@var{proc}, or the given @var{init} for the first call. If any\n" - "list is empty, just @var{init} is returned.\n" - "\n" - "@code{fold} works through the list elements from first to last.\n" - "The following shows a list reversal and the calls it makes,\n" - "\n" - "@example\n" - "(fold cons '() '(1 2 3))\n" - "\n" - "(cons 1 '())\n" - "(cons 2 '(1))\n" - "(cons 3 '(2 1)\n" - "@result{} (3 2 1)\n" - "@end example\n" - "\n" - "If @var{lst1} through @var{lstN} have different lengths,\n" - "@code{fold} stops when the end of the shortest is reached.\n" - "Ie.@: elements past the length of the shortest are ignored in\n" - "the other @var{lst}s. At least one @var{lst} must be\n" - "non-circular.\n" - "\n" - "The way @code{fold} builds a result from iterating is quite\n" - "general, it can do more than other iterations like say\n" - "@code{map} or @code{filter}. The following for example removes\n" - "adjacent duplicate elements from a list,\n" - "\n" - "@example\n" - "(define (delete-adjacent-duplicates lst)\n" - " (fold-right (lambda (elem ret)\n" - " (if (equal? elem (first ret))\n" - " ret\n" - " (cons elem ret)))\n" - " (list (last lst))\n" - " lst))\n" - "(delete-adjacent-duplicates '(1 2 3 3 4 4 4 5))\n" - "@result{} (1 2 3 4 5)\n" - "@end example\n" - "\n" - "Clearly the same sort of thing can be done with a\n" - "@code{for-each} and a variable in which to build the result,\n" - "but a self-contained @var{proc} can be re-used in multiple\n" - "contexts, where a @code{for-each} would have to be written out\n" - "each time.") -#define FUNC_NAME s_scm_srfi1_fold +SCM +scm_srfi1_fold (SCM proc, SCM init, SCM list1, SCM rest) { - SCM lst; - int argnum; - SCM_VALIDATE_REST_ARGUMENT (rest); - - if (scm_is_null (rest)) - { - /* one list */ - SCM_VALIDATE_PROC (SCM_ARG1, proc); - - for ( ; scm_is_pair (list1); list1 = SCM_CDR (list1)) - init = scm_call_2 (proc, SCM_CAR (list1), init); - - /* check below that list1 is a proper list, and done */ - lst = list1; - argnum = 2; - } - else - { - /* two or more lists */ - SCM vec, args, a; - size_t len, i; - - /* vec is the list arguments */ - vec = scm_vector (scm_cons (list1, rest)); - len = SCM_SIMPLE_VECTOR_LENGTH (vec); - - /* args is the argument list to pass to proc, same length as vec, - re-used for each call */ - args = scm_make_list (SCM_I_MAKINUM (len+1), SCM_UNDEFINED); - - for (;;) - { - /* first elem of each list in vec into args, and step those - vec entries onto their next element */ - for (i = 0, a = args, argnum = 2; - i < len; - i++, a = SCM_CDR (a), argnum++) - { - lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */ - if (! scm_is_pair (lst)) - goto check_lst_and_done; - SCM_SETCAR (a, SCM_CAR (lst)); /* arg for proc */ - SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */ - } - SCM_SETCAR (a, init); - - init = scm_apply (proc, args, SCM_EOL); - } - } - - check_lst_and_done: - SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list"); - return init; + CACHE_VAR (fold, "fold"); + return scm_apply_3 (fold, proc, init, list1, rest); } -#undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_last, "last", 1, 0, 0, - (SCM lst), - "Like @code{cons}, but with interchanged arguments. Useful\n" - "mostly when passed to higher-order procedures.") -#define FUNC_NAME s_scm_srfi1_last +SCM +scm_srfi1_last (SCM lst) { - SCM pair = scm_last_pair (lst); - /* scm_last_pair returns SCM_EOL for an empty list */ - SCM_VALIDATE_CONS (SCM_ARG1, pair); - return SCM_CAR (pair); + CACHE_VAR (last, "last"); + return scm_call_1 (last, lst); } -#undef FUNC_NAME - SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0, (SCM lst), @@ -1073,106 +976,12 @@ SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_srfi1_list_index, "list-index", 2, 0, 1, - (SCM pred, SCM list1, SCM rest), - "Return the index of the first set of elements, one from each of\n" - "@var{lst1}@dots{}@var{lstN}, which satisfies @var{pred}.\n" - "\n" - "@var{pred} is called as @code{(@var{pred} elem1 @dots{}\n" - "elemN)}. Searching stops when the end of the shortest\n" - "@var{lst} is reached. The return index starts from 0 for the\n" - "first set of elements. If no set of elements pass then the\n" - "return is @code{#f}.\n" - "\n" - "@example\n" - "(list-index odd? '(2 4 6 9)) @result{} 3\n" - "(list-index = '(1 2 3) '(3 1 2)) @result{} #f\n" - "@end example") -#define FUNC_NAME s_scm_srfi1_list_index +SCM +scm_srfi1_list_index (SCM pred, SCM list1, SCM rest) { - long n = 0; - SCM lst; - int argnum; - SCM_VALIDATE_REST_ARGUMENT (rest); - - if (scm_is_null (rest)) - { - /* one list */ - SCM_VALIDATE_PROC (SCM_ARG1, pred); - - for ( ; scm_is_pair (list1); n++, list1 = SCM_CDR (list1)) - if (scm_is_true (scm_call_1 (pred, SCM_CAR (list1)))) - return SCM_I_MAKINUM (n); - - /* not found, check below that list1 is a proper list */ - end_list1: - lst = list1; - argnum = 2; - } - else if (scm_is_pair (rest) && scm_is_null (SCM_CDR (rest))) - { - /* two lists */ - SCM list2 = SCM_CAR (rest); - SCM_VALIDATE_PROC (SCM_ARG1, pred); - - for ( ; ; n++) - { - if (! scm_is_pair (list1)) - goto end_list1; - if (! scm_is_pair (list2)) - { - lst = list2; - argnum = 3; - break; - } - if (scm_is_true (scm_call_2 (pred, - SCM_CAR (list1), SCM_CAR (list2)))) - return SCM_I_MAKINUM (n); - - list1 = SCM_CDR (list1); - list2 = SCM_CDR (list2); - } - } - else - { - /* three or more lists */ - SCM vec, args, a; - size_t len, i; - - /* vec is the list arguments */ - vec = scm_vector (scm_cons (list1, rest)); - len = SCM_SIMPLE_VECTOR_LENGTH (vec); - - /* args is the argument list to pass to pred, same length as vec, - re-used for each call */ - args = scm_make_list (SCM_I_MAKINUM (len), SCM_UNDEFINED); - - for ( ; ; n++) - { - /* first elem of each list in vec into args, and step those - vec entries onto their next element */ - for (i = 0, a = args, argnum = 2; - i < len; - i++, a = SCM_CDR (a), argnum++) - { - lst = SCM_SIMPLE_VECTOR_REF (vec, i); /* list argument */ - if (! scm_is_pair (lst)) - goto not_found_check_lst; - SCM_SETCAR (a, SCM_CAR (lst)); /* arg for pred */ - SCM_SIMPLE_VECTOR_SET (vec, i, SCM_CDR (lst)); /* rest of lst */ - } - - if (scm_is_true (scm_apply (pred, args, SCM_EOL))) - return SCM_I_MAKINUM (n); - } - } - - not_found_check_lst: - SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (lst), lst, argnum, FUNC_NAME, "list"); - return SCM_BOOL_F; + CACHE_VAR (list_index, "list-index"); + return scm_apply_2 (list_index, pred, list1, rest); } -#undef FUNC_NAME - /* This routine differs from the core list-copy in allowing improper lists. Maybe the core could allow them similarly. */ @@ -1206,25 +1015,12 @@ SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0, } #undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_list_tabulate, "list-tabulate", 2, 0, 0, - (SCM n, SCM proc), - "Return an @var{n}-element list, where each list element is\n" - "produced by applying the procedure @var{init-proc} to the\n" - "corresponding list index. The order in which @var{init-proc}\n" - "is applied to the indices is not specified.") -#define FUNC_NAME s_scm_srfi1_list_tabulate +SCM +scm_srfi1_list_tabulate (SCM n, SCM proc) { - long i, nn; - SCM ret = SCM_EOL; - nn = scm_to_signed_integer (n, 0, LONG_MAX); - SCM_VALIDATE_PROC (SCM_ARG2, proc); - for (i = nn-1; i >= 0; i--) - ret = scm_cons (scm_call_1 (proc, scm_from_long (i)), ret); - return ret; + CACHE_VAR (list_tabulate, "list-tabulate"); + return scm_call_2 (list_tabulate, n, proc); } -#undef FUNC_NAME - SCM_DEFINE (scm_srfi1_lset_adjoin, "lset-adjoin", 2, 0, 1, (SCM equal, SCM lst, SCM rest), @@ -1609,21 +1405,12 @@ SCM_DEFINE (scm_srfi1_ninth, "ninth", 1, 0, 0, } #undef FUNC_NAME - -SCM_DEFINE (scm_srfi1_not_pair_p, "not-pair?", 1, 0, 0, - (SCM obj), - "Return @code{#t} is @var{obj} is not a pair, @code{#f}\n" - "otherwise.\n" - "\n" - "This is shorthand notation @code{(not (pair? @var{obj}))} and\n" - "is supposed to be used for end-of-list checking in contexts\n" - "where dotted lists are allowed.") -#define FUNC_NAME s_scm_srfi1_not_pair_p +SCM +scm_srfi1_not_pair_p (SCM obj) { - return scm_from_bool (! scm_is_pair (obj)); + CACHE_VAR (not_pair_p, "not-pair?"); + return scm_call_1 (not_pair_p, obj); } -#undef FUNC_NAME - SCM_DEFINE (scm_srfi1_partition, "partition", 2, 0, 0, (SCM pred, SCM list), @@ -2153,17 +1940,14 @@ SCM_DEFINE (scm_srfi1_tenth, "tenth", 1, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_srfi1_xcons, "xcons", 2, 0, 0, - (SCM d, SCM a), - "Like @code{cons}, but with interchanged arguments. Useful\n" - "mostly when passed to higher-order procedures.") -#define FUNC_NAME s_scm_srfi1_xcons +SCM +scm_srfi1_xcons (SCM d, SCM a) { - return scm_cons (a, d); + CACHE_VAR (xcons, "xcons"); + return scm_call_2 (xcons, d, a); } -#undef FUNC_NAME - + void scm_init_srfi_1 (void) { diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index ecff82f..909f58c 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -1,6 +1,6 @@ ;;;; srfi-1.test --- Test suite for Guile's SRFI-1 functions. -*- scheme -*- ;;;; -;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc. +;;;; Copyright 2003, 2004, 2005, 2006, 2008, 2009, 2010 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 @@ -1563,7 +1563,7 @@ (with-test-prefix "list-tabulate" - (pass-if-exception "-1" exception:out-of-range + (pass-if-exception "-1" exception:wrong-type-arg (list-tabulate -1 identity)) (pass-if "0" (equal? '() (list-tabulate 0 identity))) -- 1.7.0