Merge commit 'cb9d473112ac172a3d328bb029b5b550918d4262' into vm-check

11 files changed, 203 insertions, 176 deletions

diff --git a/NEWS b/NEWS
index 5e3f7ae4f..29a75a9da 100644
--- a/NEWS
+++ b/NEWS
@@ -43,6 +43,10 @@ indicating length of the `scm_t_option' array.
 ** Primitive procedures (aka. "subrs") are now stored in double cells
 This removes the subr table and simplifies the code.
 
+** Primitive procedures with more than 3 arguments (aka. "gsubrs") are
+no longer implemented using the "compiled closure" mechanism.  This
+simplifies code and reduces both the storage and run-time overhead.
+
 
 Changes in 1.8.7 (since 1.8.6)
 
diff --git a/benchmark-suite/benchmarks/subr.bm b/benchmark-suite/benchmarks/subr.bm
index fbb9ed386..9c87a9921 100644
--- a/benchmark-suite/benchmarks/subr.bm
+++ b/benchmark-suite/benchmarks/subr.bm
@@ -21,6 +21,9 @@
   :use-module (benchmark-suite lib))
 
 
+(define hook1 (make-hook 1))
+(define hook3 (make-hook 3))
+
 (with-benchmark-prefix "subr invocation"
 
   (benchmark "simple subr" 700000
@@ -34,7 +37,18 @@
     ;; closures" (cclos).  There, when a cclo/gsubr is called, the evaluator
     ;; goes through `SCM_APPLY ()' and conses the arguments, which is more
     ;; costly than the invocation of a "simple subr".
-    (string= "foo" "bar")))
+    (string= "foo" "bar"))
+
+  (benchmark "generic subr with rest arg" 700000
+    ;; 1 required argument, 0 optional arguments, 1 rest.
+    (run-hook hook1 1))
+
+  (benchmark "generic subr with rest arg and 3+ parameters" 700000
+    ;; 1 required argument, 0 optional arguments, 1 rest.
+
+    ;; The evaluator considers calls with 3 and more parameters as a general
+    ;; form and always stores the arguments into a list.
+    (run-hook hook3 1 2 3)))
 
 
 (with-benchmark-prefix "subr application"
@@ -43,4 +57,10 @@
     (apply 1+ '(0)))
 
   (benchmark "generic subr" 700000
-    (apply string= "foo" '("bar"))))
+    (apply string= "foo" '("bar")))
+
+  (benchmark "generic subr with rest arg" 700000
+    (apply run-hook hook1 '(1)))
+
+  (benchmark "generic subr with rest arg and 3+ parameters" 700000
+    (run-hook hook3 1 2 '(3))))
diff --git a/configure.in b/configure.in
index b9d46e665..589053aa6 100644
--- a/configure.in
+++ b/configure.in
@@ -1541,9 +1541,6 @@ AC_CONFIG_FILES([
   examples/scripts/Makefile
   guile-config/Makefile
   lang/Makefile
-  lang/elisp/Makefile
-  lang/elisp/internals/Makefile
-  lang/elisp/primitives/Makefile
   libguile/Makefile
   scripts/Makefile
   srfi/Makefile
diff --git a/lang/Makefile.am b/lang/Makefile.am
index 5c02db63c..6dc2e2902 100644
--- a/lang/Makefile.am
+++ b/lang/Makefile.am
@@ -1,6 +1,6 @@
 ## Process this file with automake to produce Makefile.in.
 ##
-##  	Copyright (C) 2000, 2006 Free Software Foundation, Inc.
+##  	Copyright (C) 2000, 2006, 2009 Free Software Foundation, Inc.
 ##
 ##   This file is part of GUILE.
 ##   
@@ -21,4 +21,48 @@
 
 AUTOMAKE_OPTIONS = gnu
 
-SUBDIRS = elisp
+# These should be installed and distributed.
+
+elisp_sources =					\
+	elisp/base.scm				\
+	elisp/example.el			\
+	elisp/interface.scm			\
+	elisp/transform.scm			\
+	elisp/variables.scm			\
+						\
+	elisp/primitives/buffers.scm		\
+	elisp/primitives/char-table.scm		\
+	elisp/primitives/features.scm		\
+	elisp/primitives/fns.scm		\
+	elisp/primitives/format.scm		\
+	elisp/primitives/guile.scm		\
+	elisp/primitives/keymaps.scm		\
+	elisp/primitives/lists.scm		\
+	elisp/primitives/load.scm		\
+	elisp/primitives/match.scm		\
+	elisp/primitives/numbers.scm		\
+	elisp/primitives/pure.scm		\
+	elisp/primitives/read.scm		\
+	elisp/primitives/signal.scm		\
+	elisp/primitives/strings.scm		\
+	elisp/primitives/symprop.scm		\
+	elisp/primitives/syntax.scm		\
+	elisp/primitives/system.scm		\
+	elisp/primitives/time.scm		\
+						\
+	elisp/internals/evaluation.scm		\
+	elisp/internals/format.scm		\
+	elisp/internals/fset.scm		\
+	elisp/internals/lambda.scm		\
+	elisp/internals/load.scm		\
+	elisp/internals/null.scm		\
+	elisp/internals/set.scm			\
+	elisp/internals/signal.scm		\
+	elisp/internals/time.scm		\
+	elisp/internals/trace.scm
+
+subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/lang
+nobase_subpkgdata_DATA = $(elisp_sources)
+TAGS_FILES = $(nobase_subpkgdata_DATA)
+
+EXTRA_DIST = $(elisp_sources) elisp/ChangeLog-2008
diff --git a/lang/elisp/Makefile.am b/lang/elisp/Makefile.am
deleted file mode 100644
index 6f1e82fc5..000000000
--- a/lang/elisp/Makefile.am
+++ /dev/null
@@ -1,39 +0,0 @@
-## Process this file with automake to produce Makefile.in.
-##
-##  	Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
-##
-##   This file is part of GUILE.
-##   
-##   GUILE is free software; you can redistribute it and/or modify
-##   it under the terms of the GNU General Public License as
-##   published by the Free Software Foundation; either version 2, or
-##   (at your option) any later version.
-##   
-##   GUILE 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 General Public License for more details.
-##   
-##   You should have received a copy of the GNU General Public
-##   License along with GUILE; see the file COPYING.  If not, write
-##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
-##   Floor, Boston, MA 02110-1301 USA
-
-AUTOMAKE_OPTIONS = gnu
-
-SUBDIRS = internals primitives
-
-# These should be installed and distributed.
-
-elisp_sources = \
-	base.scm \
-	example.el \
-	interface.scm \
-	transform.scm \
-	variables.scm
-
-subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/lang/elisp
-subpkgdata_DATA = $(elisp_sources)
-TAGS_FILES = $(subpkgdata_DATA)
-
-EXTRA_DIST = $(elisp_sources) ChangeLog-2008
diff --git a/lang/elisp/internals/Makefile.am b/lang/elisp/internals/Makefile.am
deleted file mode 100644
index 2022a90c3..000000000
--- a/lang/elisp/internals/Makefile.am
+++ /dev/null
@@ -1,42 +0,0 @@
-## Process this file with automake to produce Makefile.in.
-##
-##  	Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006 Free Software Foundation, Inc.
-##
-##   This file is part of GUILE.
-##   
-##   GUILE is free software; you can redistribute it and/or modify
-##   it under the terms of the GNU General Public License as
-##   published by the Free Software Foundation; either version 2, or
-##   (at your option) any later version.
-##   
-##   GUILE 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 General Public License for more details.
-##   
-##   You should have received a copy of the GNU General Public
-##   License along with GUILE; see the file COPYING.  If not, write
-##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
-##   Floor, Boston, MA 02110-1301 USA
-
-AUTOMAKE_OPTIONS = gnu
-
-# These should be installed and distributed.
-
-elisp_sources = \
-	evaluation.scm \
-	format.scm \
-	fset.scm \
-	lambda.scm \
-	load.scm \
-	null.scm \
-	set.scm \
-	signal.scm \
-	time.scm \
-	trace.scm
-
-subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/lang/elisp/internals
-subpkgdata_DATA = $(elisp_sources)
-TAGS_FILES = $(subpkgdata_DATA)
-
-EXTRA_DIST = $(elisp_sources)
diff --git a/lang/elisp/primitives/Makefile.am b/lang/elisp/primitives/Makefile.am
deleted file mode 100644
index b2f62a50a..000000000
--- a/lang/elisp/primitives/Makefile.am
+++ /dev/null
@@ -1,51 +0,0 @@
-## Process this file with automake to produce Makefile.in.
-##
-##  	Copyright (C) 1998, 1999, 2000, 2001, 2004, 2006 Free Software Foundation, Inc.
-##
-##   This file is part of GUILE.
-##   
-##   GUILE is free software; you can redistribute it and/or modify
-##   it under the terms of the GNU General Public License as
-##   published by the Free Software Foundation; either version 2, or
-##   (at your option) any later version.
-##   
-##   GUILE 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 General Public License for more details.
-##   
-##   You should have received a copy of the GNU General Public
-##   License along with GUILE; see the file COPYING.  If not, write
-##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
-##   Floor, Boston, MA 02110-1301 USA
-
-AUTOMAKE_OPTIONS = gnu
-
-# These should be installed and distributed.
-
-elisp_sources = \
-	buffers.scm \
-	char-table.scm \
-	features.scm \
-	fns.scm \
-	format.scm \
-	guile.scm \
-	keymaps.scm \
-	lists.scm \
-	load.scm \
-	match.scm \
-	numbers.scm \
-	pure.scm \
-	read.scm \
-	signal.scm \
-	strings.scm \
-	symprop.scm \
-	syntax.scm \
-	system.scm \
-	time.scm
-
-subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/lang/elisp/primitives
-subpkgdata_DATA = $(elisp_sources)
-TAGS_FILES = $(subpkgdata_DATA)
-
-EXTRA_DIST = $(elisp_sources)
diff --git a/libguile/eval.i.c b/libguile/eval.i.c
index ff3b45e18..573a7b5fb 100644
--- a/libguile/eval.i.c
+++ b/libguile/eval.i.c
@@ -1140,7 +1140,7 @@ dispatch:
 	debug.info->a.proc = proc;
 	debug.info->a.args = SCM_EOL;
 #endif
-	RETURN (scm_gsubr_apply (scm_list_1 (proc)));
+	RETURN (scm_i_gsubr_apply (proc, SCM_UNDEFINED));
       case scm_tc7_pws:
 	proc = SCM_PROCEDURE (proc);
 #ifdef DEVAL
@@ -1259,7 +1259,7 @@ dispatch:
 	    debug.info->a.args = scm_cons (arg1, debug.info->a.args);
 	    debug.info->a.proc = proc;
 #endif
-	    RETURN (scm_gsubr_apply (scm_list_2 (proc, arg1)));
+	    RETURN (scm_i_gsubr_apply (proc, arg1, SCM_UNDEFINED));
 	  case scm_tc7_pws:
 	    proc = SCM_PROCEDURE (proc);
 #ifdef DEVAL
@@ -1356,15 +1356,11 @@ dispatch:
 	    if (!SCM_SMOB_APPLICABLE_P (proc))
 	      goto badfun;
 	    RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
-	  cclon:
 	  case scm_tc7_gsubr:
 #ifdef DEVAL
-	    RETURN (scm_gsubr_apply (scm_cons (proc, debug.info->a.args)));
+	    RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args));
 #else
-	    RETURN (scm_gsubr_apply
-		     (scm_cons (proc,
-				scm_cons2 (arg1, arg2,
-					   scm_ceval_args (x, env, proc)))));
+	    RETURN (scm_i_gsubr_apply (proc, arg1, arg2, SCM_UNDEFINED));
 #endif
 	  case scm_tcs_struct:
 	    if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
@@ -1494,7 +1490,7 @@ dispatch:
 	  RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
 				    SCM_CDDR (debug.info->a.args)));
 	case scm_tc7_gsubr:
-	  goto cclon;
+	  RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args));
 	case scm_tc7_pws:
 	  proc = SCM_PROCEDURE (proc);
 	  debug.info->a.proc = proc;
@@ -1557,7 +1553,15 @@ dispatch:
 	  RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
 				    scm_ceval_args (x, env, proc)));
 	case scm_tc7_gsubr:
-	  goto cclon;
+	  if (scm_is_null (SCM_CDR (x)))
+	    /* 3 arguments */
+	    RETURN (scm_i_gsubr_apply (proc, arg1, arg2, EVALCAR (x, env),
+				       SCM_UNDEFINED));
+	  else
+	    RETURN (scm_i_gsubr_apply_list (proc,
+					    scm_cons2 (arg1, arg2,
+						       scm_ceval_args (x, env,
+								       proc))));
 	case scm_tc7_pws:
 	  proc = SCM_PROCEDURE (proc);
 	  if (!SCM_CLOSUREP (proc))
@@ -1876,7 +1880,7 @@ tail:
 #else
       args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
 #endif
-      RETURN (scm_gsubr_apply (scm_cons (proc, args)));
+      RETURN (scm_i_gsubr_apply_list (proc, args));
     case scm_tc7_pws:
       proc = SCM_PROCEDURE (proc);
 #ifdef DEVAL
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 91852d5b8..2b9a29dd1 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -21,6 +21,8 @@
 #endif
 
 #include <stdio.h>
+#include <stdarg.h>
+
 #include "libguile/_scm.h"
 #include "libguile/procprop.h"
 #include "libguile/root.h"
@@ -177,18 +179,118 @@ scm_c_define_gsubr_with_generic (const char *name,
   return create_gsubr_with_generic (1, name, req, opt, rst, fcn, gf);
 }
 
+/* Apply PROC, a gsubr, to the ARGC arguments in ARGV.  ARGC is expected to
+   match the number of arguments of the underlying C function.  */
+static SCM
+gsubr_apply_raw (SCM proc, unsigned int argc, const SCM *argv)
+{
+  SCM (*fcn) ();
+  unsigned int type, argc_max;
+
+  type = SCM_GSUBR_TYPE (proc);
+  argc_max = SCM_GSUBR_REQ (type) + SCM_GSUBR_OPT (type)
+    + SCM_GSUBR_REST (type);
+
+  if (SCM_UNLIKELY (argc != argc_max))
+    /* We expect the exact argument count.  */
+    scm_wrong_num_args (SCM_SNAME (proc));
 
+  fcn = SCM_SUBRF (proc);
+
+  switch (argc)
+    {
+    case 0:
+      return (*fcn) ();
+    case 1:
+      return (*fcn) (argv[0]);
+    case 2:
+      return (*fcn) (argv[0], argv[1]);
+    case 3:
+      return (*fcn) (argv[0], argv[1], argv[2]);
+    case 4:
+      return (*fcn) (argv[0], argv[1], argv[2], argv[3]);
+    case 5:
+      return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4]);
+    case 6:
+      return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
+    case 7:
+      return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
+		     argv[6]);
+    case 8:
+      return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
+		     argv[6], argv[7]);
+    case 9:
+      return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
+		     argv[6], argv[7], argv[8]);
+    case 10:
+      return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
+		     argv[6], argv[7], argv[8], argv[9]);
+    default:
+      scm_misc_error ((char *) SCM_SNAME (proc),
+		      "gsubr invocation with more than 10 arguments not implemented",
+		      SCM_EOL);
+    }
+
+  return SCM_BOOL_F; /* Never reached. */
+}
+
+/* Apply PROC, a gsubr, to the given arguments.  Missing optional arguments
+   are added, and rest arguments are turned into a list.  */
 SCM
-scm_gsubr_apply (SCM args)
-#define FUNC_NAME "scm_gsubr_apply"
+scm_i_gsubr_apply (SCM proc, SCM arg, ...)
+{
+  unsigned int type, argc, argc_max;
+  SCM *argv;
+  va_list arg_list;
+
+  type = SCM_GSUBR_TYPE (proc);
+  argc_max = SCM_GSUBR_REQ (type) + SCM_GSUBR_OPT (type);
+  argv = alloca ((argc_max + SCM_GSUBR_REST (type)) * sizeof (*argv));
+
+  va_start (arg_list, arg);
+
+  for (argc = 0;
+       !SCM_UNBNDP (arg) && argc < argc_max;
+       argc++, arg = va_arg (arg_list, SCM))
+    argv[argc] = arg;
+
+  if (SCM_UNLIKELY (argc < SCM_GSUBR_REQ (type)))
+    scm_wrong_num_args (SCM_SNAME (proc));
+
+  /* Fill in optional arguments that were not passed.  */
+  while (argc < argc_max)
+    argv[argc++] = SCM_UNDEFINED;
+
+  if (SCM_GSUBR_REST (type))
+    {
+      /* Accumulate rest arguments in a list.  */
+      SCM *rest_loc;
+
+      argv[argc_max] = SCM_EOL;
+
+      for (rest_loc = &argv[argc_max];
+	   !SCM_UNBNDP (arg);
+	   rest_loc = SCM_CDRLOC (*rest_loc), arg = va_arg (arg_list, SCM))
+	*rest_loc = scm_cons (arg, SCM_EOL);
+
+      argc = argc_max + 1;
+    }
+
+  va_end (arg_list);
+
+  return gsubr_apply_raw (proc, argc, argv);
+}
+
+/* Apply SELF, a gsubr, to the arguments listed in ARGS.  Missing optional
+   arguments are added, and rest arguments are kept into a list.  */
+SCM
+scm_i_gsubr_apply_list (SCM self, SCM args)
+#define FUNC_NAME "scm_i_gsubr_apply"
 {
-  SCM self = SCM_CAR (args);
-  SCM (*fcn)() = SCM_SUBRF (self);
   SCM v[SCM_GSUBR_MAX];
   unsigned int typ = SCM_GSUBR_TYPE (self);
   long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
 
-  args = SCM_CDR (args);
   for (i = 0; i < SCM_GSUBR_REQ (typ); i++) {
     if (scm_is_null (args))
       scm_wrong_num_args (SCM_SNAME (self));
@@ -207,22 +309,8 @@ scm_gsubr_apply (SCM args)
     v[i] = args;
   else if (!scm_is_null (args))
     scm_wrong_num_args (SCM_SNAME (self));
-  switch (n) {
-  case 2: return (*fcn)(v[0], v[1]);
-  case 3: return (*fcn)(v[0], v[1], v[2]);
-  case 4: return (*fcn)(v[0], v[1], v[2], v[3]);
-  case 5: return (*fcn)(v[0], v[1], v[2], v[3], v[4]);
-  case 6: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5]);
-  case 7: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6]);
-  case 8: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7]);
-  case 9: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8]);
-  case 10: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8], v[9]);
-  default:
-    scm_misc_error ((char *) SCM_SNAME (self),
-		    "gsubr invocation with more than 10 arguments not implemented",
-		    SCM_EOL);
-  }
-  return SCM_BOOL_F; /* Never reached. */
+
+  return gsubr_apply_raw (self, n, v);
 }
 #undef FUNC_NAME
 
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index ea4843696..65680a02c 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -48,7 +48,8 @@ SCM_API SCM scm_c_define_gsubr_with_generic (const char *name,
 					     int req, int opt, int rst,
 					     SCM (*fcn) (), SCM *gf);
 
-SCM_API SCM scm_gsubr_apply (SCM args);
+SCM_INTERNAL SCM scm_i_gsubr_apply (SCM proc, SCM arg, ...);
+SCM_INTERNAL SCM scm_i_gsubr_apply_list (SCM proc, SCM args);
 SCM_INTERNAL void scm_init_gsubr (void);
 
 #endif  /* SCM_GSUBR_H */
diff --git a/test-suite/tests/guardians.test b/test-suite/tests/guardians.test
index 15f67e609..d60f638b7 100644
--- a/test-suite/tests/guardians.test
+++ b/test-suite/tests/guardians.test
@@ -25,11 +25,12 @@
 ;;;   they explicitly invoke GC --- in other words, they assume that GC
 ;;;   won't happen too often.
 
-(use-modules (test-suite lib)
-	     (ice-9 documentation)
-             (ice-9 weak-vector))
-
+(define-module (test-guardians)
+  :use-module (test-suite lib)
+  :use-module (ice-9 documentation)
+  :use-module (ice-9 weak-vector))
 
+
 ;;;
 ;;; miscellaneous
 ;;;