Various RTL VM and calling convention tweaks
[bpt/guile.git] / libguile / vm.c
index b2d0731..ad41180 100644 (file)
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010, 2011, 2012, 2013 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 License
@@ -37,6 +37,8 @@
 #include "programs.h"
 #include "vm.h"
 
+#include "private-gc.h" /* scm_getenv_int */
+
 static int vm_default_engine = SCM_VM_REGULAR_ENGINE;
 
 /* Unfortunately we can't snarf these: snarfed things are only loaded up from
@@ -200,14 +202,16 @@ scm_i_capture_current_stack (void)
                                  0);
 }
 
+static void vm_dispatch_hook (SCM vm, int hook_num,
+                              SCM *argv, int n) SCM_NOINLINE;
+
 static void
-vm_dispatch_hook (SCM vm, int hook_num)
+vm_dispatch_hook (SCM vm, int hook_num, SCM *argv, int n)
 {
   struct scm_vm *vp;
   SCM hook;
   struct scm_frame c_frame;
   scm_t_cell *frame;
-  SCM args[1];
   int saved_trace_level;
 
   vp = SCM_VM_DATA (vm);
@@ -240,9 +244,30 @@ vm_dispatch_hook (SCM vm, int hook_num)
 
   frame->word_0 = SCM_PACK (scm_tc7_frame);
   frame->word_1 = SCM_PACK_POINTER (&c_frame);
-  args[0] = SCM_PACK_POINTER (frame);
 
-  scm_c_run_hookn (hook, args, 1);
+  if (n == 0)
+    {
+      SCM args[1];
+
+      args[0] = SCM_PACK_POINTER (frame);
+      scm_c_run_hookn (hook, args, 1);
+    }
+  else if (n == 1)
+    {
+      SCM args[2];
+
+      args[0] = SCM_PACK_POINTER (frame);
+      args[1] = argv[0];
+      scm_c_run_hookn (hook, args, 2);
+    }
+  else
+    {
+      SCM args = SCM_EOL;
+
+      while (n--)
+        args = scm_cons (argv[n], args);
+      scm_c_run_hook (hook, scm_cons (SCM_PACK_POINTER (frame), args));
+    }
 
   vp->trace_level = saved_trace_level;
 }
@@ -391,8 +416,8 @@ static void vm_error_unbound_fluid (SCM proc, SCM fluid) SCM_NORETURN SCM_NOINLI
 static void vm_error_not_a_variable (const char *func_name, SCM x) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_apply_to_non_list (SCM x) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_kwargs_length_not_even (SCM proc) SCM_NORETURN SCM_NOINLINE;
-static void vm_error_kwargs_invalid_keyword (SCM proc) SCM_NORETURN SCM_NOINLINE;
-static void vm_error_kwargs_unrecognized_keyword (SCM proc) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_kwargs_invalid_keyword (SCM proc, SCM obj) SCM_NORETURN SCM_NOINLINE;
+static void vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_too_many_args (int nargs) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_wrong_num_args (SCM proc) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_wrong_type_apply (SCM proc) SCM_NORETURN SCM_NOINLINE;
@@ -406,15 +431,6 @@ static void vm_error_no_values (void) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_not_enough_values (void) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_continuation_not_rewindable (SCM cont) SCM_NORETURN SCM_NOINLINE;
 static void vm_error_bad_wide_string_length (size_t len) SCM_NORETURN SCM_NOINLINE;
-#if VM_CHECK_IP
-static void vm_error_invalid_address (void) SCM_NORETURN SCM_NOINLINE;
-#endif
-#if VM_CHECK_OBJECT
-static void vm_error_object (void) SCM_NORETURN SCM_NOINLINE;
-#endif
-#if VM_CHECK_FREE_VARIABLES
-static void vm_error_free_variable (void) SCM_NORETURN SCM_NOINLINE;
-#endif
 
 static void
 vm_error (const char *msg, SCM arg)
@@ -470,19 +486,19 @@ vm_error_kwargs_length_not_even (SCM proc)
 }
 
 static void
-vm_error_kwargs_invalid_keyword (SCM proc)
+vm_error_kwargs_invalid_keyword (SCM proc, SCM obj)
 {
   scm_error_scm (sym_keyword_argument_error, proc,
                  scm_from_latin1_string ("Invalid keyword"),
-                 SCM_EOL, SCM_BOOL_F);
+                 SCM_EOL, scm_list_1 (obj));
 }
 
 static void
-vm_error_kwargs_unrecognized_keyword (SCM proc)
+vm_error_kwargs_unrecognized_keyword (SCM proc, SCM kw)
 {
   scm_error_scm (sym_keyword_argument_error, proc,
                  scm_from_latin1_string ("Unrecognized keyword"),
-                 SCM_EOL, SCM_BOOL_F);
+                 SCM_EOL, scm_list_1 (kw));
 }
 
 static void
@@ -573,154 +589,87 @@ vm_error_bad_wide_string_length (size_t len)
   vm_error ("VM: Bad wide string length: ~S", scm_from_size_t (len));
 }
 
-#ifdef VM_CHECK_IP
-static void
-vm_error_invalid_address (void)
-{
-  vm_error ("VM: Invalid program address", SCM_UNDEFINED);
-}
-#endif
-
-#if VM_CHECK_OBJECT
-static void
-vm_error_object ()
-{
-  vm_error ("VM: Invalid object table access", SCM_UNDEFINED);
-}
-#endif
-
-#if VM_CHECK_FREE_VARIABLES
-static void
-vm_error_free_variable ()
-{
-  vm_error ("VM: Invalid free variable access", SCM_UNDEFINED);
-}
-#endif
 
 \f
-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))
-    scm_misc_error ("vm-engine", "too many args when making boot procedure",
-                    scm_list_1 (scm_from_long (nargs)));
+static SCM boot_continuation;
 
-  text[1] = (scm_t_uint8)nargs;
+static SCM rtl_boot_continuation;
+static SCM rtl_apply;
+static SCM rtl_values;
 
-  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;
+static const scm_t_uint32 rtl_boot_continuation_code[] = {
+  SCM_PACK_RTL_24 (scm_rtl_op_halt, 0)
+};
 
-  u8vec = scm_c_take_gc_bytevector ((scm_t_int8*)bp,
-                                    sizeof (struct scm_objcode) + sizeof (text),
-                                    SCM_BOOL_F);
-  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);
+static const scm_t_uint32 rtl_apply_code[] = {
+  SCM_PACK_RTL_24 (scm_rtl_op_apply, 0) /* proc in r1, args from r2, nargs set */
+};
 
-  return ret;
-}
-#define NUM_BOOT_PROGS 8
-static SCM
-vm_make_boot_program (long nargs)
-{
-  static SCM programs[NUM_BOOT_PROGS] = { SCM_BOOL_F, };
+static const scm_t_uint32 rtl_values_code[] = {
+  SCM_PACK_RTL_24 (scm_rtl_op_return_values, 0) /* vals from r1 */
+};
 
-  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);
-}
 
 \f
 /*
  * 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;
-  args[-1] = SCM_SMOB_DESCRIPTOR (smob).apply_trampoline;
-}
-
 static SCM
-resolve_variable (SCM what, SCM program_module)
+resolve_variable (SCM what, SCM module)
 {
   if (SCM_LIKELY (scm_is_symbol (what)))
     {
-      if (SCM_LIKELY (scm_module_system_booted_p
-                      && scm_is_true (program_module)))
-        /* might longjmp */
-        return scm_module_lookup (program_module, what);
+      if (scm_is_true (module))
+        return scm_module_lookup (module, what);
       else
-        {
-          SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
-          if (scm_is_false (v))
-            scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what));
-          else
-            return v;
-        }
+        return scm_module_lookup (scm_the_root_module (), what);
     }
   else
     {
-      SCM mod;
-      /* compilation of @ or @@
-         `what' is a three-element list: (MODNAME SYM INTERFACE?)
-         INTERFACE? is #t if we compiled @ or #f if we compiled @@
-      */
-      mod = scm_resolve_module (SCM_CAR (what));
-      if (scm_is_true (SCM_CADDR (what)))
-        mod = scm_module_public_interface (mod);
-      if (scm_is_false (mod))
-        scm_misc_error (NULL, "no such module: ~S",
-                        scm_list_1 (SCM_CAR (what)));
-      /* might longjmp */
-      return scm_module_lookup (mod, SCM_CADR (what));
+      SCM modname, sym, public;
+
+      modname = SCM_CAR (what);
+      sym = SCM_CADR (what);
+      public = SCM_CADDR (what);
+
+      if (scm_is_true (public))
+        return scm_public_lookup (modname, sym);
+      else
+        return scm_private_lookup (modname, sym);
     }
 }
   
+#define VM_MIN_STACK_SIZE      (1024)
 #define VM_DEFAULT_STACK_SIZE  (64 * 1024)
+static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE;
+
+static void
+initialize_default_stack_size (void)
+{
+  int size = scm_getenv_int ("GUILE_STACK_SIZE", vm_stack_size);
+  if (size >= VM_MIN_STACK_SIZE)
+    vm_stack_size = size;
+}
 
 #define VM_NAME   vm_regular_engine
+#define RTL_VM_NAME   rtl_vm_regular_engine
 #define FUNC_NAME "vm-regular-engine"
 #define VM_ENGINE SCM_VM_REGULAR_ENGINE
 #include "vm-engine.c"
 #undef VM_NAME
+#undef RTL_VM_NAME
 #undef FUNC_NAME
 #undef VM_ENGINE
 
 #define VM_NAME          vm_debug_engine
+#define RTL_VM_NAME   rtl_vm_debug_engine
 #define FUNC_NAME "vm-debug-engine"
 #define VM_ENGINE SCM_VM_DEBUG_ENGINE
 #include "vm-engine.c"
 #undef VM_NAME
+#undef RTL_VM_NAME
 #undef FUNC_NAME
 #undef VM_ENGINE
 
@@ -743,7 +692,7 @@ make_vm (void)
 
   vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
 
-  vp->stack_size  = VM_DEFAULT_STACK_SIZE;
+  vp->stack_size= vm_stack_size;
 
 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
   vp->stack_base = (SCM *)
@@ -1118,12 +1067,38 @@ SCM_DEFINE (scm_call_with_vm, "call-with-vm", 2, 0, 1,
 
 SCM scm_load_compiled_with_vm (SCM file)
 {
-  SCM program = scm_make_program (scm_load_objcode (file),
-                                  SCM_BOOL_F, SCM_BOOL_F);
-  
+  SCM program = scm_load_thunk_from_file (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, SCM_BOOL_F);
+  ret = scm_make_program (scm_bytecode_to_objcode (u8vec, SCM_UNDEFINED),
+                          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)
 {
@@ -1131,12 +1106,16 @@ scm_bootstrap_vm (void)
                             "scm_init_vm",
                             (scm_t_extension_init_func)scm_init_vm, NULL);
 
+  initialize_default_stack_size ();
+
   sym_vm_run = scm_from_latin1_symbol ("vm-run");
   sym_vm_error = scm_from_latin1_symbol ("vm-error");
   sym_keyword_argument_error = scm_from_latin1_symbol ("keyword-argument-error");
   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 (),
@@ -1152,6 +1131,10 @@ scm_init_vm (void)
 #ifndef SCM_MAGIC_SNARFER
 #include "libguile/vm.x"
 #endif
+
+  rtl_boot_continuation = scm_i_make_rtl_program (rtl_boot_continuation_code);
+  rtl_apply = scm_i_make_rtl_program (rtl_apply_code);
+  rtl_values = scm_i_make_rtl_program (rtl_values_code);
 }
 
 /*