refactor vm application of non-programs; boot continuation refactor

* libguile/frames.c (scm_frame_instruction_pointer):
* module/system/vm/frame.scm (frame-bindings):
  (frame-next-source, frame-call-representation): Fix a few locations
  that thought that the frame-procedure will always be a VM
  procedure.  This will not not be the case when traversing the stack of
  an application of a non-procedure.

* libguile/vm-i-system.c (call, tail-call, mv-call): Instead of
  special-casing structs and smobs at these call sites, just set up the
  stack, and jump to a generic apply loop if the proc is not a program.

* libguile/vm-engine.c: The generic apply loop is here.  Also, the boot
  program is now simply a boot continuation, and can handle any number
  of arguments.

* libguile/vm.c (make_boot_program): Update the code that makes the boot
  continuation.

libguile/frames.c

@@ -237,11 +237,16 @@ SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0, 0,
 	    "")
 #define FUNC_NAME s_scm_frame_instruction_pointer
 {
+  SCM program;
   const struct scm_objcode *c_objcode;
 
   SCM_VALIDATE_VM_FRAME (1, frame);
+  program = scm_frame_procedure (frame);
 
-  c_objcode = SCM_PROGRAM_DATA (scm_frame_procedure (frame));
+  if (!SCM_PROGRAM_P (program))
+    return SCM_INUM0;
+
+  c_objcode = SCM_PROGRAM_DATA (program);
   return scm_from_unsigned_integer ((SCM_VM_FRAME_IP (frame)
                                      - SCM_C_OBJCODE_BASE (c_objcode)));
 }

libguile/vm-engine.c

@@ -86,31 +86,55 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs)
   jump_table = jump_table_pointer;
 #endif
 
-  /* Initialization */
+  /* Initial frame */
-  {
+  CACHE_REGISTER ();
-    SCM prog = program;
+  PUSH (SCM_PACK (fp)); /* dynamic link */
+  PUSH (SCM_PACK (0)); /* mvra */
+  PUSH (SCM_PACK (ip)); /* ra */
+  PUSH (boot_continuation);
+  fp = sp + 1;
+  ip = SCM_C_OBJCODE_BASE (SCM_PROGRAM_DATA (boot_continuation));
 
-    /* Boot program */
+  /* MV-call frame, function & arguments */
-    program = vm_make_boot_program (nargs);
+  PUSH (SCM_PACK (fp)); /* dynamic link */
+  PUSH (SCM_PACK (ip + 1)); /* mvra */
+  PUSH (SCM_PACK (ip)); /* ra */
+  PUSH (program);
+  fp = sp + 1;
+  VM_ASSERT (sp + nargs < stack_limit, vm_error_too_many_args (nargs));
+  while (nargs--)
+    PUSH (*argv++);
 
-    /* Initial frame */
+  PUSH_CONTINUATION_HOOK ();
-    CACHE_REGISTER ();
+
-    PUSH (SCM_PACK (fp)); /* dynamic link */
+ apply:
-    PUSH (SCM_PACK (0)); /* mvra */
+  program = fp[-1];
-    PUSH (SCM_PACK (ip)); /* ra */
+  if (!SCM_PROGRAM_P (program))
-    CACHE_PROGRAM ();
+    {
-    PUSH (program);
+      if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
-    fp = sp + 1;
+        fp[-1] = SCM_STRUCT_PROCEDURE (program);
-    ip = SCM_C_OBJCODE_BASE (bp);
+      else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
-    /* MV-call frame, function & arguments */
+               && SCM_SMOB_APPLICABLE_P (program))
-    PUSH (SCM_PACK (0)); /* dynamic link */
+        {
-    PUSH (SCM_PACK (0)); /* mvra */
+          /* (smob arg0 ... argN) => (apply-smob smob arg0 ... argN) */
-    PUSH (SCM_PACK (0)); /* ra */
+          int i;
-    PUSH (prog);
+          PUSH (SCM_BOOL_F);
-    VM_ASSERT (sp + nargs < stack_limit, vm_error_too_many_args (nargs));
+          for (i = sp - fp; i >= 0; i--)
-    while (nargs--)
+            fp[i] = fp[i - 1];
-      PUSH (*argv++);
+          fp[-1] = SCM_SMOB_DESCRIPTOR (program).apply_trampoline_objcode;
-  }
+        }
+      else
+        {
+          SYNC_ALL();
+          vm_error_wrong_type_apply (program);
+        }
+      goto apply;
+    }
+
+  CACHE_PROGRAM ();
+  ip = SCM_C_OBJCODE_BASE (bp);
+
+  APPLY_HOOK ();
 
   /* Let's go! */
   NEXT;

libguile/vm-i-system.c

@@ -764,33 +764,8 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
   nargs = FETCH ();
 
  vm_call:
-  program = sp[-nargs];
-
   VM_HANDLE_INTERRUPTS;
 
-  if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
-    {
-      if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
-        {
-          sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
-          goto vm_call;
-        }
-      else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
-               && SCM_SMOB_APPLICABLE_P (program))
-        {
-          PUSH (program);
-          prepare_smob_call (sp, ++nargs, program);
-          goto vm_call;
-        }
-      else
-        {
-          SYNC_ALL();
-          vm_error_wrong_type_apply (program);
-        }
-    }
-
-  CACHE_PROGRAM ();
-
   {
     SCM *old_fp = fp;
 
@@ -804,8 +779,16 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
     SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0);
   }
   
-  ip = SCM_C_OBJCODE_BASE (bp);
   PUSH_CONTINUATION_HOOK ();
+
+  program = fp[-1];
+
+  if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
+    goto apply;
+
+  CACHE_PROGRAM ();
+  ip = SCM_C_OBJCODE_BASE (bp);
+
   APPLY_HOOK ();
   NEXT;
 }
@@ -815,53 +798,34 @@ VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1)
   nargs = FETCH ();
 
  vm_tail_call:
-  program = sp[-nargs];
-
   VM_HANDLE_INTERRUPTS;
 
-  if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
+  {
-    {
+    int i;
-      if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
-        {
-          sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
-          goto vm_tail_call;
-        }
-      else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
-               && SCM_SMOB_APPLICABLE_P (program))
-        {
-          PUSH (program);
-          prepare_smob_call (sp, ++nargs, program);
-          goto vm_tail_call;
-        }
-      else
-        {
-          SYNC_ALL();
-          vm_error_wrong_type_apply (program);
-        }
-    }
-  else
-    {
-      int i;
 #ifdef VM_ENABLE_STACK_NULLING
-      SCM *old_sp = sp;
+    SCM *old_sp = sp;
-      CHECK_STACK_LEAK ();
+    CHECK_STACK_LEAK ();
 #endif
 
-      /* switch programs */
+    /* shuffle down the program and the arguments */
-      CACHE_PROGRAM ();
+    for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
-      /* shuffle down the program and the arguments */
+      SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
-      for (i = -1, sp = sp - nargs + 1; i < nargs; i++)
-        SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i];
 
-      sp = fp + i - 1;
+    sp = fp + i - 1;
 
-      NULLSTACK (old_sp - sp);
+    NULLSTACK (old_sp - sp);
+  }
 
-      ip = SCM_C_OBJCODE_BASE (bp);
+  program = fp[-1];
 
-      APPLY_HOOK ();
+  if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
-      NEXT;
+    goto apply;
-    }
+
+  CACHE_PROGRAM ();
+  ip = SCM_C_OBJCODE_BASE (bp);
+
+  APPLY_HOOK ();
+  NEXT;
 }
 
 VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1)
@@ -1071,54 +1035,33 @@ VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1)
 {
   scm_t_int32 offset;
   scm_t_uint8 *mvra;
+  SCM *old_fp = fp;
   
   nargs = FETCH ();
   FETCH_OFFSET (offset);
   mvra = ip + offset;
 
- vm_mv_call:
-  program = sp[-nargs];
-
   VM_HANDLE_INTERRUPTS;
 
+  fp = sp - nargs + 1;
+  
+  ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
+  ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
+  ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
+  SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
+  SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
+  SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
+  
+  PUSH_CONTINUATION_HOOK ();
+
+  program = fp[-1];
+
   if (SCM_UNLIKELY (!SCM_PROGRAM_P (program)))
-    {
+    goto apply;
-      if (SCM_STRUCTP (program) && SCM_STRUCT_APPLICABLE_P (program))
-        {
-          sp[-nargs] = SCM_STRUCT_PROCEDURE (program);
-          goto vm_mv_call;
-        }
-      else if (SCM_NIMP (program) && SCM_TYP7 (program) == scm_tc7_smob
-               && SCM_SMOB_APPLICABLE_P (program))
-        {
-          PUSH (program);
-          prepare_smob_call (sp, ++nargs, program);
-          goto vm_mv_call;
-        }
-      else
-        {
-          SYNC_ALL();
-          vm_error_wrong_type_apply (program);
-        }
-    }
 
   CACHE_PROGRAM ();
-
-  {
-    SCM *old_fp = fp;
-
-    fp = sp - nargs + 1;
-  
-    ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0);
-    ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0);
-    ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0);
-    SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp);
-    SCM_FRAME_SET_RETURN_ADDRESS (fp, ip);
-    SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra);
-  }
-  
   ip = SCM_C_OBJCODE_BASE (bp);
-  PUSH_CONTINUATION_HOOK ();
+
   APPLY_HOOK ();
   NEXT;
 }

libguile/vm.c

@@ -597,78 +597,14 @@ vm_error_free_variable ()
 #endif
 
 
-static SCM
-really_make_boot_program (long nargs)
-{
-  SCM u8vec;
-  scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 0, 1,
-                         scm_op_make_int8_1, scm_op_halt };
-  struct scm_objcode *bp;
-  SCM ret;
 
-  if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
+static SCM boot_continuation;
-    scm_misc_error ("vm-engine", "too many args when making boot procedure",
-                    scm_list_1 (scm_from_long (nargs)));
-
-  text[1] = (scm_t_uint8)nargs;
-
-  bp = scm_gc_malloc_pointerless (sizeof (struct scm_objcode) + sizeof (text),
-                                  "boot-program");
-  memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
-  bp->len = sizeof(text);
-  bp->metalen = 0;
-
-  u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
-                                    sizeof (struct scm_objcode) + sizeof (text));
-  ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
-                          SCM_BOOL_F, SCM_BOOL_F);
-  SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT);
-
-  return ret;
-}
-#define NUM_BOOT_PROGS 8
-static SCM
-vm_make_boot_program (long nargs)
-{
-  static SCM programs[NUM_BOOT_PROGS] = { SCM_BOOL_F, };
-
-  if (SCM_UNLIKELY (scm_is_false (programs[0])))
-    {
-      int i;
-      for (i = 0; i < NUM_BOOT_PROGS; i++)
-        programs[i] = really_make_boot_program (i);
-    }
-  
-  if (SCM_LIKELY (nargs < NUM_BOOT_PROGS))
-    return programs[nargs];
-  else
-    return really_make_boot_program (nargs);
-}
 
 
 /*
  * VM
  */
 
-/* We are calling a SMOB.  The calling code pushed the SMOB after the
-   args, and incremented nargs.  That nargs is passed here.  This
-   function's job is to replace the procedure with the trampoline, and
-   shuffle the smob itself to be argument 0.  This function must not
-   allocate or throw, as the VM registers are not synchronized.  */
-static void
-prepare_smob_call (SCM *sp, int nargs, SCM smob)
-{
-  SCM *args = sp - nargs + 1;
-
-  /* Shuffle args up.  */
-  while (nargs--)
-    args[nargs + 1] = args[nargs];
-
-  args[0] = smob;
-  /* apply_trampoline_objcode is actually a program.  */
-  args[-1] = SCM_SMOB_DESCRIPTOR (smob).apply_trampoline_objcode;
-}
-
 static SCM
 resolve_variable (SCM what, SCM program_module)
 {
@@ -1124,6 +1060,33 @@ SCM scm_load_compiled_with_vm (SCM file)
   return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
 }
 
+  
+static SCM
+make_boot_program (void)
+{
+  struct scm_objcode *bp;
+  size_t bp_size;
+  SCM u8vec, ret;
+
+  const scm_t_uint8 text[] = {
+    scm_op_make_int8_1,
+    scm_op_halt
+  };
+
+  bp_size = sizeof (struct scm_objcode) + sizeof (text);
+  bp = scm_gc_malloc_pointerless (bp_size, "boot-program");
+  memcpy (SCM_C_OBJCODE_BASE (bp), text, sizeof (text));
+  bp->len = sizeof(text);
+  bp->metalen = 0;
+
+  u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp, bp_size);
+  ret = scm_make_program (scm_bytecode_to_native_objcode (u8vec),
+                          SCM_BOOL_F, SCM_BOOL_F);
+  SCM_SET_CELL_WORD_0 (ret, (SCM_CELL_WORD_0 (ret) | SCM_F_PROGRAM_IS_BOOT));
+
+  return ret;
+}
+
 void
 scm_bootstrap_vm (void)
 {
@@ -1137,6 +1100,8 @@ scm_bootstrap_vm (void)
   sym_regular = scm_from_latin1_symbol ("regular");
   sym_debug = scm_from_latin1_symbol ("debug");
 
+  boot_continuation = make_boot_program ();
+
 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
   vm_stack_gc_kind =
     GC_new_kind (GC_new_free_list (),

module/system/vm/frame.scm

@@ -1,6 +1,6 @@
 ;;; Guile VM frame functions
 
-;;; Copyright (C) 2001, 2005, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012 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
@@ -32,8 +32,10 @@
             frame-return-values))
 
 (define (frame-bindings frame)
-  (program-bindings-for-ip (frame-procedure frame)
+  (let ((p (frame-procedure frame)))
-                           (frame-instruction-pointer frame)))
+    (if (program? p)
+        (program-bindings-for-ip p (frame-instruction-pointer frame))
+        '())))
 
 (define (frame-lookup-binding frame var)
   (let lp ((bindings (frame-bindings frame)))
@@ -72,9 +74,11 @@
 
 (define (frame-next-source frame)
   (let ((proc (frame-procedure frame)))
-    (program-source proc
+    (if (program? proc)
-                    (frame-instruction-pointer frame)
+        (program-source proc
-                    (program-sources-pre-retire proc))))
+                        (frame-instruction-pointer frame)
+                        (program-sources-pre-retire proc))
+        '())))
 
 
 ;; Basically there are two cases to deal with here:
@@ -97,7 +101,8 @@
     (cons
      (or (procedure-name p) p)     
      (cond
-      ((program-arguments-alist p (frame-instruction-pointer frame))
+      ((and (program? p)
+            (program-arguments-alist p (frame-instruction-pointer frame)))
        ;; case 1
        => (lambda (arguments)
             (define (binding-ref sym i)