From 135b32ee84567a7d704fdc1f6b86997bfd970eb9 Mon Sep 17 00:00:00 2001
From: Ludovic Court`es <ludovic.courtes@laas.fr>
Date: Tue, 3 May 2005 15:13:42 +0000
Subject: [PATCH] Playing with the procedure call mechanism.

* src/objcodes.c (do-pair):  New experiment.
* src/vm_engine.h (ALIGN_AS_NON_IMMEDIATE):  New macro.
  (POP_LIST_ON_STACK):  New experimental macro.
* src/vm_engine.c (call):  In the procedure call case, I tried using the above
  macro.

git-archimport-id: lcourtes@laas.fr--2004-libre/guile-vm--revival--0.6--patch-8
---
 src/objcodes.c  | 32 ++++++++++++++++++++++
 src/vm_engine.h | 70 +++++++++++++++++++++++++++++++++++++++++++++++++
 src/vm_system.c |  5 ++++
 3 files changed, 107 insertions(+)

diff --git a/src/objcodes.c b/src/objcodes.c
index b93bed848..0e494b77a 100644
--- a/src/objcodes.c
+++ b/src/objcodes.c
@@ -124,6 +124,38 @@ objcode_free (SCM obj)
  * Scheme interface
  */
 
+#if 0
+SCM_DEFINE (scm_do_pair, "do-pair", 2, 0, 0,
+	    (SCM car, SCM cdr),
+	    "This is a stupid test to see how cells work.  (Ludo)")
+{
+  static SCM room[512];
+  static SCM *where = &room[0];
+  SCM the_pair;
+  size_t incr;
+
+  if ((scm_t_bits)where & 6)
+    {
+      /* Align the cell pointer so that Guile considers it as a
+	 non-immediate object (see tags.h).  */
+      incr = (scm_t_bits)where & 6;
+      incr = (~incr) & 7;
+      where += incr;
+    }
+
+  printf ("do-pair: pool @ %p, pair @ %p\n", &room[0], where);
+  where[0] = car;
+  where[1] = cdr;
+
+  the_pair = PTR2SCM (where);
+  /* This doesn't work because SCM_SET_GC_MARK will look for some sort of a
+     "mark bitmap" at the end of a supposed cell segment which doesn't
+     exist.  */
+
+  return (the_pair);
+}
+#endif
+
 SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0,
 	    (SCM obj),
 	    "")
diff --git a/src/vm_engine.h b/src/vm_engine.h
index 5dcb0c45f..3c7ef7b02 100644
--- a/src/vm_engine.h
+++ b/src/vm_engine.h
@@ -241,6 +241,76 @@ do						\
   PUSH (l);					\
 } while (0)
 
+
+/* Below is a (slightly broken) experiment to avoid calling `scm_cell' and to
+   allocate cells on the stack.  This is a significant improvement for
+   programs which call a lot of procedures, since the procedure call
+   mechanism uses POP_LIST which normally uses `scm_cons'.
+
+   What it does is that it creates a list whose cells are allocated on the
+   VM's stack instead of being allocated on the heap via `scm_cell'.  This is
+   much faster.  However, if the callee does something like:
+
+     (lambda (. args)
+       (set! the-args args))
+
+   then terrible things may happen since the list of arguments may be
+   overwritten later on.  */
+
+
+/* Awful hack that aligns PTR so that it can be considered as a non-immediate
+   value by Guile.  */
+#define ALIGN_AS_NON_IMMEDIATE(_ptr)		\
+{						\
+  if ((scm_t_bits)(_ptr) & 6)			\
+    {						\
+      size_t _incr;				\
+						\
+      _incr = (scm_t_bits)(_ptr) & 6;		\
+      _incr = (~_incr) & 7;			\
+      (_ptr) += _incr;				\
+    }						\
+}
+
+#define POP_LIST_ON_STACK(n)			\
+do						\
+{						\
+  int i;					\
+  if (n == 0)					\
+    {						\
+      sp -= n;					\
+      PUSH (SCM_EOL);				\
+    }						\
+  else						\
+    {						\
+      SCM *list_head, *list;			\
+						\
+      list_head = sp + 1;			\
+      ALIGN_AS_NON_IMMEDIATE (list_head);	\
+      list = list_head;				\
+						\
+      sp -= n;					\
+      for (i = 1; i <= n; i++)			\
+	{					\
+	  /* The cell's car and cdr.  */	\
+	  *(list) = sp[i];			\
+	  *(list + 1) = PTR2SCM (list + 2);	\
+	  list += 2;				\
+	}					\
+						\
+      /* The last pair's cdr is '().  */	\
+      list--;					\
+      *list = SCM_EOL;				\
+      /* Push the SCM object that points */	\
+      /* to the first cell.  */			\
+      PUSH (PTR2SCM (list_head));		\
+    }						\
+}						\
+while (0)
+
+/* end of the experiment */
+
+
 #define POP_LIST_MARK()				\
 do {						\
   SCM o;					\
diff --git a/src/vm_system.c b/src/vm_system.c
index a5cd7d0ce..dc71896dd 100644
--- a/src/vm_system.c
+++ b/src/vm_system.c
@@ -380,7 +380,12 @@ VM_DEFINE_INSTRUCTION (call, "call", 1, -1, 1)
 	 arguments.  */
       SCM args;
 
+#if 1
       POP_LIST (nargs);
+#else
+      /* Experimental:  Build the arglist on the VM stack.  XXX  */
+      POP_LIST_ON_STACK (nargs);
+#endif
       POP (args);
       *sp = scm_apply (x, args, SCM_EOL);
       NEXT;