This is the mail archive of the guile@cygnus.com mailing list for the guile project.
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
I was goofing with `ghobbit' today, and decided to try an experiment. Here's the result; a new and improved tail recursive version of `append!'. Following the patch is a test session demonstrating that it has the same behavior as the original `append!' does. `hobbit' produced two functions, a main one, and an internal function for the named let. It also used temp variables where none where needed. I pulled it together into one function, replaced some macros with the SCM versions, and called `scm_last_pair' directly, rather than via `apply' like hobbit does. (I think it does that so that if "last-pair" is redefined, that `last-pair' would be called, rather than `scm_last_pair'.) It looks more efficient than the old version as well; it will not use any extra stack frames since it tail calls with a `goto' inside what was the scheme named let expression, rather than calling itself recursively with pending operations. 1998-09-08 Karl M. Hegbloom <karlheg@bittersweet.inetarena.com> * list.c (scm_append_x): tail recursive version from scm compiled by hobbit then hand optimized. Index: list.c =================================================================== RCS file: /usr/local/cvsroot/debian/guile-core/libguile/list.c,v retrieving revision 1.1.1.1 diff -u -u -r1.1.1.1 list.c --- libguile/list.c 1998/08/26 17:14:05 1.1.1.1 +++ libguile/list.c 1998/09/08 23:26:28 @@ -165,6 +165,7 @@ SCM_PROC (s_append, "append", 0, 0, 1, scm_append); SCM + scm_append(args) SCM args; { @@ -193,7 +194,63 @@ } } +#define HOBBITIZED_APPEND_X 1 +#ifdef HOBBITIZED_APPEND_X +/* + * The following function was first compiled with ghobbit: + * + * (define (append! . args) + * (let ((ret (car args)) + * (args (cdr args))) + * (if (null? args) + * ret + * (let append-x ((tailp (last-pair ret)) + * (first (car args)) + * (rest (cdr args))) + * (set-cdr! tailp first) + * (if (null? rest) + * ret + * (append-x (last-pair first) + * (car rest) + * (cdr rest))))))) + * + * ... and then hand-optimized to its present state. + * + */ +SCM_PROC(s_append_x, "append!", 0, 0, 1, scm_append_x); +SCM +scm_append_x(args) + SCM args; +{ + SCM ret; + + SCM_ASSERT (SCM_NIMP (args) && SCM_CONSP (args), args, SCM_ARG1, s_append_x); + + ret = SCM_CAR (args); + args = SCM_CDR (args); + if (SCM_NULLP (args)) + return ret; + else { + + SCM tailp = scm_last_pair (ret); + SCM first = SCM_CAR (args); + SCM rest = SCM_CDR (args); + + tailrecursion: + SCM_SETCDR (tailp, first); + if (SCM_NULLP (rest)) + return ret; + else { + tailp = scm_last_pair (first); + first = SCM_CAR (rest); + rest = SCM_CDR (rest); + goto tailrecursion; + } + } +} + +#else SCM_PROC (s_append_x, "append!", 0, 0, 1, scm_append_x); SCM scm_append_x(args) @@ -210,7 +267,7 @@ SCM_SETCDR (scm_last_pair (arg), scm_append_x (args)); return arg; } - +#endif /* HOBBITIZED_APPEND_X */ SCM_PROC(s_last_pair, "last-pair", 1, 0, 0, scm_last_pair); SCM guile> (let ((ls1 '(a b c d)) (ls2 '(e f g h)) (ls3 '(i j k l))) (newline) (display (append! ls1 ls2 ls3)) (newline) (display ls1) (newline)) (a b c d e f g h i j k l) (a b c d e f g h i j k l) guile> (let ((ls1 '(a b c d)) (ls2 '(e f g h)) (ls3 '(i j k l))) (newline) (display (append! ls1 ls2 ls3 'a)) (newline) (display ls1) (newline)) (a b c d e f g h i j k l . a) (a b c d e f g h i j k l . a) guile> (let ((ls1 '(a b c d)) (ls2 '(e f g h)) (ls3 '(i j k l))) (newline) (display (append! ls1 ls2 ls3 'a 'b)) (newline) (display ls1) (newline)) Backtrace: 0* (let ((ls1 #) (ls2 #) (ls3 #)) (newline) ...) 1* [display ... 2* [append! (a b c ...) (e f g ...) ...] ERROR: In procedure append! in expression (append! ls1 ls2 ...): ERROR: Wrong type argument in position 1: a ABORT: (wrong-type-arg) guile> -- mailto:karlheg@debian.org (Karl M. Hegbloom) http://www.inetarena.com/~karlheg Portland, OR USA Debian GNU 2.0 Linux 2.0.35 AMD K6-233 XEmacs-21.2beta