VM has "builtins": primitives addressable by emitted RTL code

* libguile/Makefile.am:
* libguile/vm-builtins.h: New header, declaring stubs needed by the
  compiler like values, apply, and abort-to-prompt.

* libguile/vm.c: Adapt the apply and values stubs to conform to a
  standard interface.  Add an abort-to-prompt stub.  Add call/cc and
  call-with-values stubs.
  (scm_vm_builtin_ref): New helper, for the builtin-ref opcode.
  (scm_vm_builtin_name_to_index)
  (scm_vm_builtin_index_to_name): New helpers, for the compiler and
  disassembler, respectively.
  (scm_init_vm_builtins, scm_bootstrap_vm): Allow the compiler helpers
  to be loaded later into a module.
* module/language/rtl.scm: Export builtin-index->name and
  builtin-name->index.

* libguile/vm-engine.c (RETURN_VALUE_LIST): Update to use new names of
  "apply" and "values".
  (tail-call/shuffle): New opcode.
  (abort): Update to be a tail VM op, and reorder and renumber other
  ops.
  (builtin-ref): New opcode.

* libguile/continuations.h:
* libguile/continuations.c (scm_i_call_with_current_continuation):
  Move this to vm.[ch], implemented as a builtin.

* module/language/tree-il/compile-cps.scm (convert): Convert to
  'abort-to-prompt calls, possibly with 'apply, effectively undoing the
  tree-il transformation.

* module/language/cps/reify-primitives.scm (builtin-ref): New helper.
  (reify-primitives): Convert builtin primitives to builtin-ref.

* module/language/cps/dfg.scm (constant-needs-allocation?):
* module/language/cps/compile-rtl.scm (emit-rtl-sequence): Add support
  for compiling builtin-ref.

* module/system/vm/disassembler.scm (code-annotation): Add annotation
  for builtin-ref.

libguile/Makefile.am

@@ -639,6 +639,7 @@ modinclude_HEADERS =				\
 	values.h				\
 	variable.h				\
 	vectors.h				\
+	vm-builtins.h				\
 	vm-expand.h				\
 	vm.h					\
 	vports.h				\

libguile/continuations.c

@@ -68,15 +68,6 @@ static const scm_t_uint32 continuation_stub_code[] =
     SCM_PACK_RTL_24 (scm_rtl_op_continuation_call, 0)
   };
 
-/* Before Scheme's call/cc is compiled, eval.c will use this hand-coded
-   call/cc. */
-
-static const scm_t_uint32 call_cc_code[] =
-  {
-    SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, 2),
-    SCM_PACK_RTL_24 (scm_rtl_op_call_cc, 0)
-  };
-
 static SCM
 make_continuation_trampoline (SCM contregs)
 {
@@ -174,17 +165,6 @@ scm_i_make_continuation (int *first, SCM vm, SCM vm_cont)
 }
 #undef FUNC_NAME
 
-SCM
-scm_i_call_with_current_continuation (SCM proc)
-{
-  static SCM call_cc = SCM_BOOL_F;
-
-  if (scm_is_false (call_cc))
-    call_cc = scm_i_make_rtl_program (call_cc_code);
-  
-  return scm_call_1 (call_cc, proc);
-}
-
 SCM
 scm_i_continuation_to_frame (SCM continuation)
 {

libguile/continuations.h

@@ -74,8 +74,6 @@ SCM_INTERNAL SCM scm_i_make_continuation (int *first, SCM vm, SCM vm_cont);
 SCM_INTERNAL void scm_i_check_continuation (SCM cont);
 SCM_INTERNAL void scm_i_reinstate_continuation (SCM cont);
 
-SCM_INTERNAL SCM scm_i_call_with_current_continuation (SCM proc);
-
 SCM_INTERNAL SCM scm_i_continuation_to_frame (SCM cont);
 SCM_INTERNAL SCM scm_i_contregs_vm (SCM contregs);
 SCM_INTERNAL SCM scm_i_contregs_vm_cont (SCM contregs);

libguile/vm-builtins.h

@@ -0,0 +1,46 @@
+/* Copyright (C) 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
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library 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
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#ifndef _SCM_VM_BUILTINS_H_
+#define _SCM_VM_BUILTINS_H_
+
+#ifdef BUILDING_LIBGUILE
+
+#define FOR_EACH_VM_BUILTIN(M) \
+  M(apply, APPLY) \
+  M(values, VALUES) \
+  M(abort_to_prompt, ABORT_TO_PROMPT) \
+  M(call_with_values, CALL_WITH_VALUES) \
+  M(call_with_current_continuation, CALL_WITH_CURRENT_CONTINUATION)
+
+/* These enumerated values are embedded in RTL code, and as such are
+   part of Guile's ABI.  */
+enum scm_vm_builtins
+{
+#define ENUM(builtin, BUILTIN) SCM_VM_BUILTIN_##BUILTIN,
+  FOR_EACH_VM_BUILTIN(ENUM)
+#undef ENUM
+  SCM_VM_BUILTIN_COUNT
+};
+
+SCM_INTERNAL SCM scm_vm_builtin_name_to_index (SCM name);
+SCM_INTERNAL SCM scm_vm_builtin_index_to_name (SCM idx);
+
+#endif /* BUILDING_LIBGUILE */
+
+#endif /* _SCM_VM_BUILTINS_H_ */

libguile/vm.c

@@ -36,6 +36,7 @@
 #include "objcodes.h"
 #include "programs.h"
 #include "vm.h"
+#include "vm-builtins.h"
 
 #include "private-gc.h" /* scm_getenv_int */
 
@@ -602,21 +603,120 @@ vm_error_bad_wide_string_length (size_t len)
 static SCM boot_continuation;
 
 static SCM rtl_boot_continuation;
-static SCM rtl_apply;
+static SCM vm_builtin_apply;
-static SCM rtl_values;
+static SCM vm_builtin_values;
+static SCM vm_builtin_abort_to_prompt;
+static SCM vm_builtin_call_with_values;
+static SCM vm_builtin_call_with_current_continuation;
 
 static const scm_t_uint32 rtl_boot_continuation_code[] = {
   SCM_PACK_RTL_24 (scm_rtl_op_halt, 0)
 };
 
-static const scm_t_uint32 rtl_apply_code[] = {
+static const scm_t_uint32 vm_builtin_apply_code[] = {
-  SCM_PACK_RTL_24 (scm_rtl_op_tail_apply, 0) /* proc in r1, args from r2, nargs set */
+  SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, 3),
+  SCM_PACK_RTL_24 (scm_rtl_op_tail_apply, 0), /* proc in r1, args from r2 */
 };
 
-static const scm_t_uint32 rtl_values_code[] = {
+static const scm_t_uint32 vm_builtin_values_code[] = {
   SCM_PACK_RTL_24 (scm_rtl_op_return_values, 0) /* vals from r1 */
 };
 
+static const scm_t_uint32 vm_builtin_abort_to_prompt_code[] = {
+  SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ge, 2),
+  SCM_PACK_RTL_24 (scm_rtl_op_abort, 0), /* tag in r1, vals from r2 */
+  /* FIXME: Partial continuation should capture caller regs.  */
+  SCM_PACK_RTL_24 (scm_rtl_op_return_values, 0) /* vals from r1 */
+};
+
+static const scm_t_uint32 vm_builtin_call_with_values_code[] = {
+  SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, 3),
+  SCM_PACK_RTL_24 (scm_rtl_op_alloc_frame, 7),
+  SCM_PACK_RTL_12_12 (scm_rtl_op_mov, 6, 1),
+  SCM_PACK_RTL_24 (scm_rtl_op_call, 6), SCM_PACK_RTL_24 (0, 1),
+  SCM_PACK_RTL_12_12 (scm_rtl_op_mov, 0, 2),
+  SCM_PACK_RTL_24 (scm_rtl_op_tail_call_shuffle, 7)
+};
+
+static const scm_t_uint32 vm_builtin_call_with_current_continuation_code[] = {
+  SCM_PACK_RTL_24 (scm_rtl_op_assert_nargs_ee, 2),
+  SCM_PACK_RTL_24 (scm_rtl_op_call_cc, 0)
+};
+
+
+static SCM
+scm_vm_builtin_ref (unsigned idx)
+{
+  switch (idx)
+    {
+#define INDEX_TO_NAME(builtin, BUILTIN) \
+      case SCM_VM_BUILTIN_##BUILTIN: return vm_builtin_##builtin;
+      FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
+#undef INDEX_TO_NAME
+      default: abort();
+    }
+}
+
+static SCM scm_sym_values;
+static SCM scm_sym_abort_to_prompt;
+static SCM scm_sym_call_with_values;
+static SCM scm_sym_call_with_current_continuation;
+
+SCM
+scm_vm_builtin_name_to_index (SCM name)
+#define FUNC_NAME "builtin-name->index"
+{
+  SCM_VALIDATE_SYMBOL (1, name);
+
+#define NAME_TO_INDEX(builtin, BUILTIN)                 \
+  if (scm_is_eq (name, scm_sym_##builtin))              \
+    return scm_from_uint (SCM_VM_BUILTIN_##BUILTIN);
+  FOR_EACH_VM_BUILTIN(NAME_TO_INDEX)
+#undef NAME_TO_INDEX
+
+  return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM
+scm_vm_builtin_index_to_name (SCM index)
+#define FUNC_NAME "builtin-index->name"
+{
+  unsigned idx;
+
+  SCM_VALIDATE_UINT_COPY (1, index, idx);
+
+  switch (idx)
+    {
+#define INDEX_TO_NAME(builtin, BUILTIN) \
+      case SCM_VM_BUILTIN_##BUILTIN: return scm_sym_##builtin;
+      FOR_EACH_VM_BUILTIN(INDEX_TO_NAME)
+#undef INDEX_TO_NAME
+      default: return SCM_BOOL_F;
+    }
+}
+#undef FUNC_NAME
+
+static void
+scm_init_vm_builtins (void)
+{
+  scm_sym_values = scm_from_utf8_symbol ("values");
+  scm_sym_abort_to_prompt = scm_from_utf8_symbol ("abort-to-prompt");
+  scm_sym_call_with_values = scm_from_utf8_symbol ("call-with-values");
+  scm_sym_call_with_current_continuation =
+    scm_from_utf8_symbol ("call-with-current-continuation");
+
+  scm_c_define_gsubr ("builtin-name->index", 1, 0, 0,
+                      scm_vm_builtin_name_to_index);
+  scm_c_define_gsubr ("builtin-index->name", 1, 0, 0,
+                      scm_vm_builtin_index_to_name);
+}
+
+SCM
+scm_i_call_with_current_continuation (SCM proc)
+{
+  return scm_call_1 (vm_builtin_call_with_current_continuation, proc);
+}
 
 
 /*
@@ -659,7 +759,7 @@ resolve_variable (SCM what, SCM module)
 }
   
 #define VM_MIN_STACK_SIZE	(1024)
-#define VM_DEFAULT_STACK_SIZE	(64 * 1024)
+#define VM_DEFAULT_STACK_SIZE	(256 * 1024)
 static size_t vm_stack_size = VM_DEFAULT_STACK_SIZE;
 
 static void
@@ -781,10 +881,10 @@ scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
 {
   struct scm_vm *vp = SCM_VM_DATA (vm);
   SCM_CHECK_STACK;
-  if (SCM_RTL_PROGRAM_P (program))
+  if (SCM_PROGRAM_P (program))
-    return rtl_vm_engines[vp->engine](vm, program, argv, nargs);
-  else
     return vm_engines[vp->engine](vm, program, argv, nargs);
+  else
+    return rtl_vm_engines[vp->engine](vm, program, argv, nargs);
 }
 
 /* Scheme interface */
@@ -1130,6 +1230,10 @@ scm_bootstrap_vm (void)
   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                             "scm_init_vm",
                             (scm_t_extension_init_func)scm_init_vm, NULL);
+  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+                            "scm_init_vm_builtins",
+                            (scm_t_extension_init_func)scm_init_vm_builtins,
+                            NULL);
 
   initialize_default_stack_size ();
 
@@ -1145,8 +1249,14 @@ scm_bootstrap_vm (void)
   SCM_SET_CELL_WORD_0 (rtl_boot_continuation,
                        (SCM_CELL_WORD_0 (rtl_boot_continuation)
                         | SCM_F_PROGRAM_IS_BOOT));
-  rtl_apply = scm_i_make_rtl_program (rtl_apply_code);
+  vm_builtin_apply = scm_i_make_rtl_program (vm_builtin_apply_code);
-  rtl_values = scm_i_make_rtl_program (rtl_values_code);
+  vm_builtin_values = scm_i_make_rtl_program (vm_builtin_values_code);
+  vm_builtin_abort_to_prompt =
+    scm_i_make_rtl_program (vm_builtin_abort_to_prompt_code);
+  vm_builtin_call_with_values =
+    scm_i_make_rtl_program (vm_builtin_call_with_values_code);
+  vm_builtin_call_with_current_continuation =
+    scm_i_make_rtl_program (vm_builtin_call_with_current_continuation_code);
 
 #ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
   vm_stack_gc_kind =

libguile/vm.h

@@ -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
@@ -107,6 +107,7 @@ SCM_INTERNAL SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
 
 SCM_INTERNAL void scm_i_vm_print (SCM x, SCM port,
                                   scm_print_state *pstate);
+SCM_INTERNAL SCM scm_i_call_with_current_continuation (SCM proc);
 SCM_INTERNAL SCM scm_i_capture_current_stack (void);
 SCM_INTERNAL SCM scm_i_vm_capture_stack (SCM *stack_base, SCM *fp, SCM *sp,
                                          scm_t_uint8 *ra, scm_t_uint8 *mvra,

module/language/cps/compile-rtl.scm

@@ -211,6 +211,8 @@
                   (emit-constant-vector-ref asm dst (slot vector) index)))
             (else
              (emit-vector-ref asm dst (slot vector) (slot index)))))
+          (($ $primcall 'builtin-ref (name))
+           (emit-builtin-ref asm dst (constant name)))
           (($ $primcall name args)
            ;; FIXME: Inline all the cases.
            (let ((inst (prim-rtl-instruction name)))

module/language/cps/dfg.scm

@@ -810,6 +810,8 @@
               (not (and (eq? sym i) (immediate-u8? val))))
              (($ $primcall 'vector-set! (v i x))
               (not (and (eq? sym i) (immediate-u8? val))))
+             (($ $primcall 'builtin-ref (idx))
+              #f)
              (_ #t)))
          uses))))))
 

module/language/cps/reify-primitives.scm

@@ -50,6 +50,13 @@
                 (build-cps-term
                   ($continue k ($primcall 'box-ref (box)))))))
 
+(define (builtin-ref idx k)
+  (let-gensyms (idx-sym)
+    (build-cps-term
+      ($letconst (('idx idx-sym idx))
+        ($continue k
+          ($primcall 'builtin-ref (idx-sym)))))))
+
 (define (reify-clause ktail)
   (let-gensyms (kclause kbody wna false str eol kthrow throw)
     (build-cps-cont
@@ -97,7 +104,12 @@
          ,(match exp
             (($ $prim name)
              (match (lookup-cont k conts)
-               (($ $kargs (_)) (primitive-ref name k))
+               (($ $kargs (_))
+                (cond
+                 ((builtin-name->index name)
+                  => (lambda (idx)
+                       (builtin-ref idx k)))
+                 (else (primitive-ref name k))))
                (_ (build-cps-term ($continue k ($void))))))
             (($ $fun)
              (build-cps-term ($continue k ,(visit-fun exp))))
@@ -114,7 +126,11 @@
                  (build-cps-term
                    ($letk ((k* #f ($kargs (v) (v)
                                     ($continue k ($call v args)))))
-                     ,(primitive-ref name k*)))))))
+                     ,(cond
+                       ((builtin-name->index name)
+                        => (lambda (idx)
+                             (builtin-ref idx k*)))
+                       (else (primitive-ref name k*)))))))))
             (_ term)))))
 
     (visit-fun fun)))

module/language/rtl.scm

@@ -23,7 +23,12 @@
   #:use-module ((srfi srfi-1) #:select (fold))
   #:use-module (system vm instruction)
   #:re-export (rtl-instruction-list)
-  #:export (rtl-instruction-arity))
+  #:export (rtl-instruction-arity
+            builtin-name->index
+            builtin-index->name))
+
+(load-extension (string-append "libguile-" (effective-version))
+                "scm_init_vm_builtins")
 
 (define (compute-rtl-instruction-arity name args)
   (define (first-word-arity word)

module/language/tree-il/compile-cps.scm

@@ -433,10 +433,20 @@
         k
         subst)))
 
-    (($ <abort> src tag args tail)
+    (($ <abort> src tag args ($ <const> _ ()))
-     (convert-args (append (list tag) args (list tail))
+     (convert-args (cons tag args)
        (lambda (args*)
-         (build-cps-term ($continue k ($primcall 'abort args*))))))
+         (build-cps-term
+           ($continue k ($primcall 'abort-to-prompt args*))))))
+
+    (($ <abort> src tag args tail)
+     (convert-args (append (list (make-primitive-ref #f 'abort-to-prompt)
+                                 tag)
+                           args
+                           (list tail))
+       (lambda (args*)
+         (build-cps-term
+           ($continue k ($primcall 'apply args*))))))
 
     (($ <conditional> src test consequent alternate)
      (let-gensyms (kif kt kf)

module/system/vm/disassembler.scm

@@ -19,7 +19,7 @@
 ;;; Code:
 
 (define-module (system vm disassembler)
-  #:use-module (system vm instruction)
+  #:use-module (language rtl)
   #:use-module (system vm elf)
   #:use-module (system vm debug)
   #:use-module (system vm program)
@@ -250,6 +250,8 @@ address of that offset."
              nfree)))
     (('make-non-immediate dst target)
      (list "~@Y" (reference-scm target)))
+    (('builtin-ref dst idx)
+     (list "~A" (builtin-index->name idx)))
     (((or 'static-ref 'static-set!) _ target)
      (list "~@Y" (dereference-scm target)))
     (('link-procedure! src target)