add new rtl vm

* libguile/vm-engine.c (rtl_vm_engine): Add new VM.
  (vm_engine): Add support for calling RTL programs.

* libguile/tags.h (scm_tc7_rtl_program): New type for procedures that
  run on the new VM.
* libguile/evalext.c (scm_self_evaluating_p):
* libguile/goops.c (scm_class_of):
* libguile/print.c (iprin1):
* libguile/procprop.c (scm_i_procedure_arity):
* libguile/procs.c (scm_procedure_p): Add hooks for the new tc7.

* libguile/programs.h:
* libguile/programs.c (scm_make_rtl_program, scm_i_rtl_program_print)
  (scm_rtl_program_p, scm_rtl_program_code):
* module/system/vm/program.scm: Add constructors and accessors for the
  new "RTL programs".

* libguile/vm.c (rtl_boot_continuation): Define a boot program.
  (rtl_apply, rtl_values): New static RTL programs.

* libguile/frames.c (scm_frame_num_locals): Adapt for frames of RTL
  programs.

* libguile/frames.h: Add description of RTL frames.

* libguile/Makefile.am: Add rules to generate vm-operations.h.
* .gitignore: Ignore vm-operations.h.
* module/system/vm/instruction.scm:
* libguile/instructions.c:
* libguile/instructions.h: Use vm-operations.h to define enumerated
  values for the new RTL opcodes.  Define some helper macros to pack and
  unpack 32-bit instruction words.
  (rtl-instruction-list): New function, exported by (system vm
  instruction).

* libguile/objcodes.c: Wire up the bits needed to detect the new RTL
  bytecode and load it, as appropriate.

.gitignore

@@ -156,3 +156,4 @@ INSTALL
 /test-suite/standalone/test-smob-mark
 /test-suite/standalone/test-scm-values
 /test-suite/standalone/test-scm-to-latin1-string
+/libguile/vm-operations.h

libguile/Makefile.am

@@ -433,9 +433,18 @@ DOT_I_FILES = vm-i-system.i vm-i-scheme.i vm-i-loader.i
 .c.i:
 	$(AM_V_GEN)$(GREP) '^VM_DEFINE' $< > $@
 
+vm-operations.h: vm-engine.c
+	@echo '/* This file was generated automatically from $<; do not' > $@
+	@echo '   edit.  See the source file for copyright information.  */' >> $@
+	@echo '' >> $@
+	@echo "#define FOR_EACH_VM_OPERATION(M) \\" >> $@
+	$(AM_V_GEN)$(GREP) '^ *VM_DEFINE_OP' $< \
+	| sed -e 's,VM_DEFINE_OP (\(.*\)).*,  M (\1) \\,' >> $@
+	@echo '' >> $@
+
 BUILT_SOURCES = cpp-E.c cpp-SIG.c libpath.h \
     scmconfig.h \
-    $(DOT_I_FILES) $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
+    $(DOT_I_FILES) vm-operations.h $(DOT_X_FILES) $(EXTRA_DOT_X_FILES)
 
 # Force the generation of `guile-procedures.texi' because the top-level
 # Makefile expects it to be built.

libguile/evalext.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 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 License
@@ -87,6 +87,7 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
 	case scm_tc7_number:
 	case scm_tc7_string:
 	case scm_tc7_smob:
+	case scm_tc7_rtl_program:
 	case scm_tc7_program:
 	case scm_tc7_bytevector:
 	case scm_tc7_array:

libguile/frames.c

@@ -129,11 +129,21 @@ SCM_DEFINE (scm_frame_num_locals, "frame-num-locals", 1, 0, 0,
 	    "")
 #define FUNC_NAME s_scm_frame_num_locals
 {
-  SCM *sp, *p;
+  SCM *fp, *sp, *p;
   unsigned int n = 0;
 
   SCM_VALIDATE_VM_FRAME (1, frame);
 
+  fp = SCM_VM_FRAME_FP (frame);
+  sp = SCM_VM_FRAME_SP (frame);
+  p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
+
+  if (SCM_RTL_PROGRAM_P (fp[-1]))
+    /* The frame size of an RTL program is fixed, except in the case of
+       passing a wrong number of arguments to the program.  So we do
+       need to use an SP for determining the number of locals.  */
+    return scm_from_uint32 (sp + 1 - p);
+
   sp = SCM_VM_FRAME_SP (frame);
   p = SCM_FRAME_STACK_ADDRESS (SCM_VM_FRAME_FP (frame));
   while (p <= sp)

libguile/frames.h

@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 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 License
@@ -98,6 +98,37 @@ struct scm_vm_frame
 #define SCM_FRAME_PROGRAM(fp)                   \
   (SCM_FRAME_STRUCT (fp)->program)
 
+
+/*
+ * RTL frames
+ */
+
+/* The frame format for the new RTL programs is almost like that for the
+   stack-vm programs.  They differ in their handling of MV returns,
+   however.  For RTL, every call is an MV call: every call has an MVRA.
+   Unlike the stack-vm programs, the MVRA for RTL programs is computable
+   from the RA -- it's always one word (4 bytes) before the RA.
+
+   Until we completely migrate to the RTL VM, we will also write the
+   MVRA to the stack.
+
+   When an RTL program returns multiple values, it will shuffle them
+   down to start contiguously from slot 0, as for a tail call.  This
+   means that when the caller goes to access them, there are 2 or 3
+   empty words between the top of the caller stack and the bottom of the
+   values, corresponding to the frame that was just popped.
+*/
+
+#define SCM_FRAME_RTL_RETURN_ADDRESS(fp)                \
+  ((scm_t_uint32 *) SCM_FRAME_RETURN_ADDRESS (fp))
+#define SCM_FRAME_SET_RTL_RETURN_ADDRESS(fp, ip)        \
+  SCM_FRAME_SET_RETURN_ADDRESS (fp, (scm_t_uint8 *) (ip))
+
+#define SCM_FRAME_RTL_MV_RETURN_ADDRESS(fp)             \
+  ((scm_t_uint32 *) SCM_FRAME_MV_RETURN_ADDRESS (fp))
+#define SCM_FRAME_SET_RTL_MV_RETURN_ADDRESS(fp, ip)     \
+  SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, (scm_t_uint8 *) (ip))
+
 
 /*
  * Heap frames

libguile/goops.c

@@ -301,6 +301,9 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
 	  else
 	    return scm_class_procedure;
 
+	case scm_tc7_rtl_program:
+          return scm_class_procedure;
+
 	case scm_tc7_smob:
 	  {
 	    scm_t_bits type = SCM_TYP16 (x);

libguile/instructions.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 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
@@ -40,6 +40,83 @@ struct scm_instruction {
   SCM symname;                  /* filled in later */
 };
 
+
+#define OP_HAS_ARITY (1U << 0)
+
+#define FOR_EACH_INSTRUCTION_WORD_TYPE(M)       \
+    M(X32)                                      \
+    M(U8_X24)                                   \
+    M(U8_U24)                                   \
+    M(U8_L24)                                   \
+    M(U8_R24)                                   \
+    M(U8_U8_I16)                                \
+    M(U8_U8_U8_U8)                              \
+    M(U8_U12_U12)                               \
+    M(U32) /* Unsigned. */                      \
+    M(I32) /* Immediate. */                     \
+    M(A32) /* Immediate, high bits. */          \
+    M(B32) /* Immediate, low bits. */           \
+    M(N32) /* Non-immediate. */                 \
+    M(S32) /* Scheme value (indirected). */     \
+    M(L32) /* Label. */                         \
+    M(LO32) /* Label with offset. */            \
+    M(X8_U24)                                   \
+    M(X8_U12_U12)                               \
+    M(X8_R24)                                   \
+    M(X8_L24)                                   \
+    M(B1_X7_L24)                                \
+    M(B1_U7_L24)
+
+#define TYPE_WIDTH 5
+
+enum word_type
+  {
+#define ENUM(type) type,
+    FOR_EACH_INSTRUCTION_WORD_TYPE (ENUM)
+#undef ENUM
+  };
+
+static SCM word_type_symbols[] =
+  {
+#define FALSE(type) SCM_BOOL_F,
+    FOR_EACH_INSTRUCTION_WORD_TYPE (FALSE)
+#undef FALSE
+  };
+
+#define OP(n,type) ((type) << (n*TYPE_WIDTH))
+
+/* The VM_DEFINE_OP macro uses a CPP-based DSL to describe what kinds of
+   arguments each RTL instruction takes.  This piece of code is the only
+   bit that actually interprets that language.  These macro definitions
+   encode the operand types into bits in a 32-bit integer.
+
+   (rtl-instruction-list) parses those encoded values into lists of
+   symbols, one for each 32-bit word that the operator takes.  (system
+   vm rtl) uses those word types to generate assemblers and
+   disassemblers for the instructions.  */
+
+#define OP1(type0) \
+  (OP (0, type0))
+#define OP2(type0, type1) \
+  (OP (0, type0) | OP (1, type1))
+#define OP3(type0, type1, type2) \
+  (OP (0, type0) | OP (1, type1) | OP (2, type2))
+#define OP4(type0, type1, type2, type3) \
+  (OP (0, type0) | OP (1, type1) | OP (2, type2) | OP (3, type3))
+
+#define OP_DST (1 << (TYPE_WIDTH * 5))
+
+#define WORD_TYPE(n, word) \
+  (((word) >> ((n) * TYPE_WIDTH)) & ((1 << TYPE_WIDTH) - 1))
+
+struct scm_rtl_instruction {
+  enum scm_rtl_opcode opcode;	/* opcode */
+  const char *name;		/* instruction name */
+  scm_t_uint32 meta;
+  SCM symname;                  /* filled in later */
+};
+
+
 #define SCM_VALIDATE_LOOKUP_INSTRUCTION(pos, var, cvar)               \
   do {                                                                \
     cvar = scm_lookup_instruction_by_name (var);                      \
@@ -82,6 +159,37 @@ fetch_instruction_table ()
   return table;
 }
 
+static struct scm_rtl_instruction*
+fetch_rtl_instruction_table ()
+{
+  static struct scm_rtl_instruction *table = NULL;
+
+  scm_i_pthread_mutex_lock (&itable_lock);
+  if (SCM_UNLIKELY (!table))
+    {
+      size_t bytes = SCM_VM_NUM_INSTRUCTIONS * sizeof(struct scm_rtl_instruction);
+      int i;
+      table = malloc (bytes);
+      memset (table, 0, bytes);
+
+#define INIT(opcode, tag, name_, meta_) table[opcode].name = name_; table[opcode].meta = meta_;
+      FOR_EACH_VM_OPERATION (INIT);
+#undef INIT
+
+      for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
+        {
+          table[i].opcode = i;
+          if (table[i].name)
+            table[i].symname = scm_from_utf8_symbol (table[i].name);
+          else
+            table[i].symname = SCM_BOOL_F;
+        }
+    }
+  scm_i_pthread_mutex_unlock (&itable_lock);
+
+  return table;
+}
+
 static struct scm_instruction *
 scm_lookup_instruction_by_name (SCM name)
 {
@@ -127,6 +235,57 @@ SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_rtl_instruction_list, "rtl-instruction-list", 0, 0, 0,
+	    (void),
+	    "")
+#define FUNC_NAME s_scm_rtl_instruction_list
+{
+  SCM list = SCM_EOL;
+  int i;
+  struct scm_rtl_instruction *ip = fetch_rtl_instruction_table ();
+  for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
+    if (ip[i].name)
+      {
+        scm_t_uint32 meta = ip[i].meta;
+        SCM tail = SCM_EOL;
+        int len;
+
+        /* Format: (name opcode len rest? out br in) */
+
+        if (WORD_TYPE (3, meta))
+          len = 4;
+        else if (WORD_TYPE (2, meta))
+          len = 3;
+        else if (WORD_TYPE (1, meta))
+          len = 2;
+        else if (WORD_TYPE (0, meta))
+          len = 1;
+        else
+          abort ();
+
+        switch (len)
+          {
+          case 4:
+            tail = scm_cons (word_type_symbols[WORD_TYPE (3, meta)], tail);
+          case 3:
+            tail = scm_cons (word_type_symbols[WORD_TYPE (2, meta)], tail);
+          case 2:
+            tail = scm_cons (word_type_symbols[WORD_TYPE (1, meta)], tail);
+          case 1:
+            tail = scm_cons (word_type_symbols[WORD_TYPE (0, meta)], tail);
+          default:
+            tail = scm_cons (scm_from_int (ip[i].opcode), tail);
+            tail = scm_cons (ip[i].symname, tail);
+            break;
+          }
+
+        list = scm_cons (tail, list);
+      }
+
+  return scm_reverse_x (list, SCM_EOL);
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0,
 	    (SCM obj),
 	    "")
@@ -208,6 +367,11 @@ scm_bootstrap_instructions (void)
                             "scm_init_instructions",
                             (scm_t_extension_init_func)scm_init_instructions,
                             NULL);
+
+#define INIT(type) \
+  word_type_symbols[type] = scm_from_utf8_symbol (#type);
+    FOR_EACH_INSTRUCTION_WORD_TYPE (INIT)
+#undef INIT
 }
 
 void

libguile/instructions.h

@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 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 License
@@ -20,6 +20,59 @@
 #define _SCM_INSTRUCTIONS_H_
 
 #include <libguile.h>
+#include <libguile/vm-operations.h>
+
+enum scm_rtl_opcode
+  {
+#define ENUM(opcode, tag, name, meta) scm_rtl_op_##tag = opcode,
+    FOR_EACH_VM_OPERATION(ENUM)
+#undef ENUM
+  };
+
+#define SCM_PACK_RTL_8_8_8(op,a,b,c) ((op) | ((a) << 8) | ((b) << 16) | ((d) << 24))
+#define SCM_PACK_RTL_8_16(op,a,b) ((op) | ((a) << 8) | ((b) << 16))
+#define SCM_PACK_RTL_16_8(op,a,b) ((op) | ((a) << 16) | ((b) << 24))
+#define SCM_PACK_RTL_24(op,a) ((op) | ((a) << 8))
+
+#define SCM_UNPACK_RTL_8_8_8(op,a,b,c)    \
+  do                                      \
+    {                                     \
+      a = (op >> 8) & 0xff;               \
+      b = (op >> 16) & 0xff;              \
+      c = op >> 24;                       \
+    }                                     \
+  while (0)
+
+#define SCM_UNPACK_RTL_8_16(op,a,b)       \
+  do                                      \
+    {                                     \
+      a = (op >> 8) & 0xff;               \
+      b = op >> 16;                       \
+    }                                     \
+  while (0)
+
+#define SCM_UNPACK_RTL_16_8(op,a,b)       \
+  do                                      \
+    {                                     \
+      a = (op >> 8) & 0xffff;             \
+      b = op >> 24;                       \
+    }                                     \
+  while (0)
+
+#define SCM_UNPACK_RTL_12_12(op,a,b)      \
+  do                                      \
+    {                                     \
+      a = (op >> 8) & 0xfff;              \
+      b = op >> 20;                       \
+    }                                     \
+  while (0)
+
+#define SCM_UNPACK_RTL_24(op,a)           \
+  do                                      \
+    {                                     \
+      a = op >> 8;                        \
+    }                                     \
+  while (0)
 
 #define SCM_VM_NUM_INSTRUCTIONS (1<<8)
 #define SCM_VM_INSTRUCTION_MASK (SCM_VM_NUM_INSTRUCTIONS-1)
@@ -33,6 +86,8 @@ enum scm_opcode {
 #undef VM_INSTRUCTION_TO_OPCODE
 };
 
+SCM_INTERNAL SCM scm_rtl_instruction_list (void);
+
 SCM_API SCM scm_instruction_list (void);
 SCM_API SCM scm_instruction_p (SCM obj);
 SCM_API SCM scm_instruction_length (SCM inst);

libguile/objcodes.c

@@ -94,7 +94,8 @@ static void register_elf (char *data, size_t len);
 enum bytecode_kind
   {
     BYTECODE_KIND_NONE,
-    BYTECODE_KIND_GUILE_2_0
+    BYTECODE_KIND_GUILE_2_0,
+    BYTECODE_KIND_GUILE_2_2
   };
 
 static SCM
@@ -110,6 +111,10 @@ pointer_to_procedure (enum bytecode_kind bytecode_kind, char *ptr)
         objcode = scm_double_cell (tag, (scm_t_bits) ptr, SCM_BOOL_F_BITS, 0);
         return scm_make_program (objcode, SCM_BOOL_F, SCM_UNDEFINED);
       }
+    case BYTECODE_KIND_GUILE_2_2:
+      {
+        return scm_i_make_rtl_program ((scm_t_uint32 *) ptr);
+      }
     case BYTECODE_KIND_NONE:
     default:
       abort ();
@@ -302,29 +307,52 @@ process_dynamic_segment (char *base, Elf_Phdr *dyn_phdr,
           {
             scm_t_uint16 major = dyn[i].d_un.d_val >> 16;
             scm_t_uint16 minor = dyn[i].d_un.d_val & 0xffff;
-            if (major != 0x0200)
+            switch (major)
-              return "incompatible bytecode kind";
+              {
-            if (minor > SCM_OBJCODE_MINOR_VERSION)
+              case 0x0200:
-              return "incompatible bytecode version";
+                bytecode_kind = BYTECODE_KIND_GUILE_2_0;
-            bytecode_kind = BYTECODE_KIND_GUILE_2_0;
+                if (minor > SCM_OBJCODE_MINOR_VERSION)
+                  return "incompatible bytecode version";
+                break;
+              case 0x0202:
+                bytecode_kind = BYTECODE_KIND_GUILE_2_2;
+                if (minor)
+                  return "incompatible bytecode version";
+                break;
+              default:
+                return "incompatible bytecode kind";
+              }
             break;
           }
         }
     }
 
-  if (bytecode_kind != BYTECODE_KIND_GUILE_2_0)
-    return "missing DT_GUILE_RTL_VERSION";
-  if (init)
-    return "unexpected DT_INIT";
-  if ((scm_t_uintptr) entry % 8)
-    return "unaligned DT_GUILE_ENTRY";
   if (!entry)
     return "missing DT_GUILE_ENTRY";
 
+  switch (bytecode_kind)
+    {
+    case BYTECODE_KIND_GUILE_2_0:
+      if (init)
+        return "unexpected DT_INIT";
+      if ((scm_t_uintptr) entry % 8)
+        return "unaligned DT_GUILE_ENTRY";
+      break;
+    case BYTECODE_KIND_GUILE_2_2:
+      if ((scm_t_uintptr) init % 4)
+        return "unaligned DT_INIT";
+      if ((scm_t_uintptr) entry % 4)
+        return "unaligned DT_GUILE_ENTRY";
+      break;
+    case BYTECODE_KIND_NONE:
+    default:
+      return "missing DT_GUILE_RTL_VERSION";
+    }
+
   if (gc_root)
     GC_add_roots (gc_root, gc_root + gc_root_size);
 
-  *init_out = SCM_BOOL_F;
+  *init_out = init ? pointer_to_procedure (bytecode_kind, init) : SCM_BOOL_F;
   *entry_out = pointer_to_procedure (bytecode_kind, entry);
   return NULL;
 }

libguile/print.c

@@ -656,6 +656,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
 	case scm_tc7_variable:
 	  scm_i_variable_print (exp, port, pstate);
 	  break;
+	case scm_tc7_rtl_program:
+	  scm_i_rtl_program_print (exp, port, pstate);
+	  break;
 	case scm_tc7_program:
 	  scm_i_program_print (exp, port, pstate);
 	  break;

libguile/procprop.c

@@ -80,6 +80,14 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
              see.  */
           *req -= 1;
 
+          return 1;
+        }
+      else if (SCM_RTL_PROGRAM_P (proc))
+        {
+          *req = 0;
+          *opt = 0;
+          *rest = 1;
+
           return 1;
         }
       else

libguile/procs.c

@@ -1,5 +1,5 @@
 /* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2006, 2008, 2009,
- *   2010, 2011, 2012 Free Software Foundation, Inc.
+ *   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
@@ -48,6 +48,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
 #define FUNC_NAME s_scm_procedure_p
 {
   return scm_from_bool (SCM_PROGRAM_P (obj)
+                        || SCM_RTL_PROGRAM_P (obj)
                         || (SCM_STRUCTP (obj) && SCM_STRUCT_APPLICABLE_P (obj))
                         || (SCM_HAS_TYP7 (obj, scm_tc7_smob)
                             && SCM_SMOB_APPLICABLE_P (obj)));

libguile/programs.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 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
@@ -69,6 +69,58 @@ SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_make_rtl_program, "make-rtl-program", 1, 2, 0,
+	    (SCM bytevector, SCM byte_offset, SCM free_variables),
+	    "")
+#define FUNC_NAME s_scm_make_rtl_program
+{
+  scm_t_uint8 *code;
+  scm_t_uint32 offset;
+
+  if (!scm_is_bytevector (bytevector))
+    scm_wrong_type_arg (FUNC_NAME, 1, bytevector);
+  if (SCM_UNBNDP (byte_offset))
+    offset = 0;
+  else
+    {
+      offset = scm_to_uint32 (byte_offset);
+      if (offset > SCM_BYTEVECTOR_LENGTH (bytevector))
+        SCM_OUT_OF_RANGE (2, byte_offset);
+    }
+
+  code = (scm_t_uint8*) SCM_BYTEVECTOR_CONTENTS (bytevector) + offset;
+  if (((scm_t_uintptr) code) % 4)
+    SCM_OUT_OF_RANGE (2, byte_offset);
+
+  if (SCM_UNBNDP (free_variables) || scm_is_false (free_variables))
+    return scm_cell (scm_tc7_rtl_program, (scm_t_bits) code);
+  else
+    abort ();
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_rtl_program_code, "rtl-program-code", 1, 0, 0,
+            (SCM program),
+            "")
+#define FUNC_NAME s_scm_rtl_program_code
+{
+  SCM_VALIDATE_RTL_PROGRAM (1, program);
+
+  /* FIXME: we need scm_from_uintptr ().  */
+  return scm_from_size_t ((size_t) SCM_RTL_PROGRAM_CODE (program));
+}
+#undef FUNC_NAME
+
+void
+scm_i_rtl_program_print (SCM program, SCM port, scm_print_state *pstate)
+{
+  scm_puts_unlocked ("#<rtl-program ", port);
+  scm_uintprint (SCM_UNPACK (program), 16, port);
+  scm_putc_unlocked (' ', port);
+  scm_uintprint ((scm_t_uintptr) SCM_RTL_PROGRAM_CODE (program), 16, port);
+  scm_putc_unlocked ('>', port);
+}
+
 void
 scm_i_program_print (SCM program, SCM port, scm_print_state *pstate)
 {
@@ -121,6 +173,15 @@ SCM_DEFINE (scm_program_p, "program?", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM_DEFINE (scm_rtl_program_p, "rtl-program?", 1, 0, 0,
+	    (SCM obj),
+	    "")
+#define FUNC_NAME s_scm_rtl_program_p
+{
+  return scm_from_bool (SCM_RTL_PROGRAM_P (obj));
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0,
 	    (SCM program),
 	    "")

libguile/programs.h

@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009, 2010, 2011 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
@@ -22,6 +22,31 @@
 #include <libguile.h>
 #include <libguile/objcodes.h>
 
+/*
+ * The new RTL programs.
+ */
+
+#define SCM_RTL_PROGRAM_P(x) (SCM_HAS_TYP7 (x, scm_tc7_rtl_program))
+#define SCM_RTL_PROGRAM_CODE(x) ((scm_t_uint32 *) SCM_CELL_WORD_1 (x))
+#define SCM_RTL_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_OBJECT_LOC (x, 2))
+#define SCM_RTL_PROGRAM_FREE_VARIABLE_REF(x,i) (SCM_RTL_PROGRAM_FREE_VARIABLES (x)[i])
+#define SCM_RTL_PROGRAM_FREE_VARIABLE_SET(x,i,v) (SCM_RTL_PROGRAM_FREE_VARIABLES (x)[i]=(v))
+#define SCM_RTL_PROGRAM_NUM_FREE_VARIABLES(x) (SCM_CELL_WORD_0 (x) >> 16)
+#define SCM_VALIDATE_RTL_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, RTL_PROGRAM_P)
+
+static inline SCM
+scm_i_make_rtl_program (const scm_t_uint32 *code)
+{
+  return scm_cell (scm_tc7_rtl_program, (scm_t_bits)code);
+}
+
+SCM_INTERNAL SCM scm_make_rtl_program (SCM bytevector, SCM byte_offset, SCM free_variables);
+SCM_INTERNAL SCM scm_rtl_program_p (SCM obj);
+SCM_INTERNAL SCM scm_rtl_program_code (SCM program);
+
+SCM_INTERNAL void scm_i_rtl_program_print (SCM program, SCM port,
+                                           scm_print_state *pstate);
+
 /*
  * Programs
  */

libguile/tags.h

@@ -425,7 +425,7 @@ typedef union SCM { struct { scm_t_bits n; } n; } SCM;
 
 #define scm_tc7_unused_17	61
 #define scm_tc7_unused_21	63
-#define scm_tc7_unused_19	69
+#define scm_tc7_rtl_program	69
 #define scm_tc7_program		79
 #define scm_tc7_weak_set	85
 #define scm_tc7_weak_table	87

libguile/vm.c

@@ -594,6 +594,30 @@ vm_error_bad_wide_string_length (size_t len)
 
 static SCM boot_continuation;
 
+static SCM rtl_boot_continuation;
+static SCM rtl_apply;
+static SCM rtl_values;
+
+static const scm_t_uint32 rtl_boot_continuation_code[] = {
+  SCM_PACK_RTL_24 (scm_rtl_op_halt_values, 0), /* empty stack frame in r0-r2, results from r3 */
+  SCM_PACK_RTL_24 (scm_rtl_op_halt, 0) /* result in r0 */
+};
+
+static scm_t_uint32* rtl_boot_multiple_value_continuation_code =
+  (scm_t_uint32 *) rtl_boot_continuation_code;
+
+static scm_t_uint32* rtl_boot_single_value_continuation_code =
+  (scm_t_uint32 *) rtl_boot_continuation_code + 1;
+
+static const scm_t_uint32 rtl_apply_code[] = {
+  SCM_PACK_RTL_24 (scm_rtl_op_apply, 0) /* proc in r0, args from r1, nargs set */
+};
+
+static const scm_t_uint32 rtl_values_code[] = {
+  SCM_PACK_RTL_24 (scm_rtl_op_values, 0) /* vals from r0 */
+};
+
+
 
 /*
  * VM
@@ -637,18 +661,22 @@ initialize_default_stack_size (void)
 }
 
 #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
 
@@ -1110,6 +1138,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);
 }
 
 /*

module/system/vm/instruction.scm

@@ -1,6 +1,6 @@
 ;;; Guile VM instructions
 
-;; Copyright (C) 2001, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2010, 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
@@ -19,7 +19,8 @@
 ;;; Code:
 
 (define-module (system vm instruction)
-  #:export (instruction-list
+  #:export (rtl-instruction-list
+            instruction-list
            instruction? instruction-length
            instruction-pops instruction-pushes
            instruction->opcode opcode->instruction))

module/system/vm/program.scm

@@ -26,6 +26,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:export (make-program
+            make-rtl-program
 
             make-binding binding:name binding:boxed? binding:index
             binding:start binding:end
@@ -43,6 +44,7 @@
 
             program-meta
             program-objcode program? program-objects
+            rtl-program? rtl-program-code
             program-module program-base
             program-free-variables
             program-num-free-variables