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]

Hobbit works! : [patch] Tail recursive `append!'



 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