Add intrinsics for a baseline compiler

Since there's no optimization in the baseline compiler, there's no sense
in instruction explosion.

* libguile/intrinsics.h:
* libguile/intrinsics.c ($car, $cdr, $set-car!, $set-cdr!,
  $variable-ref, $variable-set!, $vector-length, $vector-ref,
  $vector-set!, $vector-ref/immediate, $vector-set!, $allocate-struct,
  $struct-vtable, $struct-ref, $struct-set!  $struct-ref/immediate,
  $struct-set!): New intrinsics.
* libguile/jit.c (compile_call_scm_scm, compile_call_scm_scm_slow)
  (compile_call_scm_scm_scm, compile_call_scm_scm_scm_slow)
  (compile_call_scm_uimm_scm, compile_call_scm_uimm_scm_slow): New
  code generators.
* libguile/vm-engine.c (call-scm-scm, call-scm-scm-scm,
  call-scm-uimm-scm): New instructions.
* module/system/vm/assembler.scm (emit-null?, emit-false?, emit-nil?):
  Export these.  Also export emitters for the new intrinsics.
  (define-scm-scm-intrinsic, define-scm-uimm-scm-intrinsic)
  (define-scm-scm-scm-intrinsic): New helpers.
* doc/ref/vm.texi (Intrinsic Call Instructions): Add new instructions.

doc/ref/vm.texi

@@ -1144,6 +1144,22 @@ Call the @code{SCM}-returning instrinsic with index @var{idx}, passing
 Place the @code{scm} result in @var{dst}.
 @end deftypefn
 
+@deftypefn Instruction {} call-scm-scm s12:@var{a} s12:@var{b} c32:@var{idx}
+Call the @code{void}-returning instrinsic with index @var{idx}, passing
+@code{scm} locals @var{a} and @var{b} as arguments.
+@end deftypefn
+
+@deftypefn Instruction {} call-scm-scm-scm s8:@var{a} s8:@var{b} s8:@var{c} c32:@var{idx}
+Call the @code{void}-returning instrinsic with index @var{idx}, passing
+@code{scm} locals @var{a}, @var{b}, and @var{c} as arguments.
+@end deftypefn
+
+@deftypefn Instruction {} call-scm-uimm-scm s8:@var{a} c8:@var{b} s8:@var{c} c32:@var{idx}
+Call the @code{void}-returning instrinsic with index @var{idx}, passing
+@code{scm} local @var{a}, @code{uint8_t} immediate @var{b}, and
+@code{scm} local @var{c} as arguments.
+@end deftypefn
+
 There are corresponding macro-instructions for specific intrinsics.
 These are equivalent to @code{call-@var{instrinsic-kind}} instructions
 with the appropriate intrinsic @var{idx} arguments.
@@ -1302,6 +1318,29 @@ Look up @var{sym} in module @var{mod}, placing the resulting variable in
 @deffn {Macro Instruction} current-module dst
 Set @var{dst} to the current module.
 @end deffn
+@deffn {Macro Instruction} $car dst src
+@deffnx {Macro Instruction} $cdr dst src
+@deffnx {Macro Instruction} $set-car! x val
+@deffnx {Macro Instruction} $set-cdr! x val
+@deffnx {Macro Instruction} $variable-ref dst src
+@deffnx {Macro Instruction} $variable-set! x val
+@deffnx {Macro Instruction} $vector-length dst x
+@deffnx {Macro Instruction} $vector-ref dst x idx
+@deffnx {Macro Instruction} $vector-ref/immediate dst x idx/imm
+@deffnx {Macro Instruction} $vector-set! x idx v
+@deffnx {Macro Instruction} $vector-set!/immediate x idx/imm v
+@deffnx {Macro Instruction} $allocate-struct dst vtable nwords
+@deffnx {Macro Instruction} $struct-vtable dst src
+@deffnx {Macro Instruction} $struct-ref dst src idx
+@deffnx {Macro Instruction} $struct-ref/immediate dst src idx/imm
+@deffnx {Macro Instruction} $struct-set! x idx v
+@deffnx {Macro Instruction} $struct-set!/immediate x idx/imm v
+Intrinsics for use by the baseline compiler.  The usual strategy for CPS
+compilation is to expose the component parts of e.g. @code{vector-ref}
+so that the compiler can learn from them and eliminate needless bits.
+However in the non-optimizing baseline compiler, that's just overhead,
+so we have some intrinsics that encapsulate all the usual type checks.
+@end deffn
 
 
 @node Constant Instructions

libguile/intrinsics.c

@@ -1,4 +1,4 @@
-/* Copyright 2018-2019
+/* Copyright 2018-2020
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -36,8 +36,10 @@
 #include "keywords.h"
 #include "modules.h"
 #include "numbers.h"
+#include "struct.h"
 #include "symbols.h"
 #include "threads.h"
+#include "variable.h"
 #include "version.h"
 
 #include "intrinsics.h"
@@ -470,6 +472,52 @@ scm_atan1 (SCM x)
   return scm_atan (x, SCM_UNDEFINED);
 }
 
+static void
+set_car_x (SCM x, SCM y)
+{
+  scm_set_car_x (x, y);
+}
+static void
+set_cdr_x (SCM x, SCM y)
+{
+  scm_set_cdr_x (x, y);
+}
+static void
+variable_set_x (SCM x, SCM y)
+{
+  scm_variable_set_x (x, y);
+}
+static void
+vector_set_x (SCM x, SCM y, SCM z)
+{
+  scm_vector_set_x (x, y, z);
+}
+static SCM
+vector_ref_immediate (SCM x, uint8_t idx)
+{
+  return scm_c_vector_ref (x, idx);
+}
+static void
+vector_set_x_immediate (SCM x, uint8_t idx, SCM z)
+{
+  scm_c_vector_set_x (x, idx, z);
+}
+static void
+struct_set_x (SCM x, SCM y, SCM z)
+{
+  scm_struct_set_x (x, y, z);
+}
+static SCM
+struct_ref_immediate (SCM x, uint8_t idx)
+{
+  return scm_struct_ref (x, scm_from_uint8 (idx));
+}
+static void
+struct_set_x_immediate (SCM x, uint8_t idx, SCM z)
+{
+  scm_struct_set_x (x, scm_from_uint8 (idx), z);
+}
+
 void
 scm_bootstrap_intrinsics (void)
 {
@@ -566,6 +614,25 @@ scm_bootstrap_intrinsics (void)
     allocate_pointerless_words_with_freelist;
   scm_vm_intrinsics.inexact = scm_exact_to_inexact;
 
+  /* Intrinsics for the baseline compiler. */
+  scm_vm_intrinsics.car = scm_car;
+  scm_vm_intrinsics.cdr = scm_cdr;
+  scm_vm_intrinsics.set_car_x = set_car_x;
+  scm_vm_intrinsics.set_cdr_x = set_cdr_x;
+  scm_vm_intrinsics.variable_ref = scm_variable_ref;
+  scm_vm_intrinsics.variable_set_x = variable_set_x;
+  scm_vm_intrinsics.vector_length = scm_vector_length;
+  scm_vm_intrinsics.vector_ref = scm_vector_ref;
+  scm_vm_intrinsics.vector_set_x = vector_set_x;
+  scm_vm_intrinsics.vector_ref_immediate = vector_ref_immediate;
+  scm_vm_intrinsics.vector_set_x_immediate = vector_set_x_immediate;
+  scm_vm_intrinsics.allocate_struct = scm_allocate_struct;
+  scm_vm_intrinsics.struct_vtable = scm_struct_vtable;
+  scm_vm_intrinsics.struct_ref = scm_struct_ref;
+  scm_vm_intrinsics.struct_set_x = struct_set_x;
+  scm_vm_intrinsics.struct_ref_immediate = struct_ref_immediate;
+  scm_vm_intrinsics.struct_set_x_immediate = struct_set_x_immediate;
+  
   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                             "scm_init_intrinsics",
                             (scm_t_extension_init_func)scm_init_intrinsics,

libguile/intrinsics.h

@@ -1,4 +1,4 @@
-/* Copyright 2018-2019
+/* Copyright 2018-2020
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -97,6 +97,9 @@ typedef SCM (*scm_t_scm_from_ptr_scm_scm_intrinsic) (SCM*, SCM, SCM);
 typedef double (*scm_t_f64_from_f64_intrinsic) (double);
 typedef double (*scm_t_f64_from_f64_f64_intrinsic) (double, double);
 typedef uint32_t* scm_t_vcode_intrinsic;
+typedef void (*scm_t_scm_scm_intrinsic) (SCM, SCM);
+typedef void (*scm_t_scm_scm_scm_intrinsic) (SCM, SCM, SCM);
+typedef void (*scm_t_scm_uimm_scm_intrinsic) (SCM, uint8_t, SCM);
 
 #define SCM_FOR_ALL_VM_INTRINSICS(M) \
   M(scm_from_scm_scm, add, "add", ADD) \
@@ -192,8 +195,28 @@ typedef uint32_t* scm_t_vcode_intrinsic;
   M(scm_from_thread_sz, allocate_pointerless_words_with_freelist, "allocate-pointerless-words/freelist", ALLOCATE_POINTERLESS_WORDS_WITH_FREELIST) \
   M(scm_from_scm, inexact, "inexact", INEXACT) \
   M(f64_from_s64, s64_to_f64, "s64->f64", S64_TO_F64) \
+  M(scm_from_scm, car, "$car", CAR) \
+  M(scm_from_scm, cdr, "$cdr", CDR) \
+  M(scm_scm, set_car_x, "$set-car!", SET_CAR_X) \
+  M(scm_scm, set_cdr_x, "$set-cdr!", SET_CDR_X) \
+  M(scm_from_scm, variable_ref, "$variable-ref", VARIABLE_REF) \
+  M(scm_scm, variable_set_x, "$variable-set!", VARIABLE_SET_X) \
+  M(scm_from_scm, vector_length, "$vector-length", VECTOR_LENGTH) \
+  M(scm_from_scm_scm, vector_ref, "$vector-ref", VECTOR_REF) \
+  M(scm_scm_scm, vector_set_x, "$vector-set!", VECTOR_SET_X) \
+  M(scm_from_scm_uimm, vector_ref_immediate, "$vector-ref/immediate", VECTOR_REF_IMMEDIATE) \
+  M(scm_uimm_scm, vector_set_x_immediate, "$vector-set!/immediate", VECTOR_SET_X_IMMEDIATE) \
+  M(scm_from_scm_scm, allocate_struct, "$allocate-struct", ALLOCATE_STRUCT) \
+  M(scm_from_scm, struct_vtable, "$struct-vtable", STRUCT_VTABLE) \
+  M(scm_from_scm_scm, struct_ref, "$struct-ref", STRUCT_REF) \
+  M(scm_scm_scm, struct_set_x, "$struct-set!", STRUCT_SET_X) \
+  M(scm_from_scm_uimm, struct_ref_immediate, "$struct-ref/immediate", STRUCT_REF_IMMEDIATE) \
+  M(scm_uimm_scm, struct_set_x_immediate, "$struct-set!/immediate", STRUCT_SET_X_IMMEDIATE) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
+/* Intrinsics prefixed with $ are meant to reduce bytecode size,
+   notably for the baseline compiler.  */
+
 enum scm_vm_intrinsic
   {
 #define DEFINE_ENUM(type, id, name, ID) SCM_VM_INTRINSIC_##ID,

libguile/jit.c

@@ -3146,6 +3146,56 @@ compile_call_scm_from_thread_slow (scm_jit_state *j, uint32_t dst, uint32_t idx)
 {
 }
 
+static void
+compile_call_scm_scm (scm_jit_state *j, uint16_t a, uint16_t b, uint32_t idx)
+{
+  void *intrinsic = ((void **) &scm_vm_intrinsics)[idx];
+
+  emit_store_current_ip (j, T0);
+  emit_call_2 (j, intrinsic, sp_scm_operand (j, a), sp_scm_operand (j, b));
+  emit_reload_sp (j);
+}
+static void
+compile_call_scm_scm_slow (scm_jit_state *j, uint16_t a, uint16_t b,
+                           uint32_t idx)
+{
+}
+
+static void
+compile_call_scm_scm_scm (scm_jit_state *j, uint8_t a, uint8_t b, uint8_t c,
+                          uint32_t idx)
+{
+  void *intrinsic = ((void **) &scm_vm_intrinsics)[idx];
+
+  emit_store_current_ip (j, T0);
+  emit_call_3 (j, intrinsic, sp_scm_operand (j, a), sp_scm_operand (j, b),
+               sp_scm_operand (j, c));
+  emit_reload_sp (j);
+}
+static void
+compile_call_scm_scm_scm_slow (scm_jit_state *j, uint8_t a, uint8_t b,
+                               uint8_t c, uint32_t idx)
+{
+}
+
+static void
+compile_call_scm_uimm_scm (scm_jit_state *j, uint8_t a, uint8_t b, uint8_t c,
+                           uint32_t idx)
+{
+  void *intrinsic = ((void **) &scm_vm_intrinsics)[idx];
+
+  emit_store_current_ip (j, T0);
+  emit_call_3 (j, intrinsic, sp_scm_operand (j, a),
+               jit_operand_imm (JIT_OPERAND_ABI_UINT8, b),
+               sp_scm_operand (j, c));
+  emit_reload_sp (j);
+}
+static void
+compile_call_scm_uimm_scm_slow (scm_jit_state *j, uint8_t a, uint8_t b,
+                                uint8_t c, uint32_t idx)
+{
+}
+
 static void
 compile_fadd (scm_jit_state *j, uint8_t dst, uint8_t a, uint8_t b)
 {
@@ -5262,6 +5312,8 @@ compile_s64_to_f64_slow (scm_jit_state *j, uint16_t dst, uint16_t src)
   }
 #define COMPILE_X8_S8_S8_S8__C32(j, comp)                               \
   COMPILE_X8_S8_S8_C8__C32(j, comp)
+#define COMPILE_X8_S8_C8_S8__C32(j, comp)                               \
+  COMPILE_X8_S8_S8_C8__C32(j, comp)
 
 #define COMPILE_X32__LO32__L32(j, comp)                                 \
   {                                                                     \

libguile/vm-engine.c

@@ -3319,9 +3319,63 @@ VM_NAME (scm_thread *thread)
       NEXT (1);
     }
 
-  VM_DEFINE_OP (160, unused_160, NULL, NOP)
+  /* call-scm-scm a:12 b:12 IDX:32
-  VM_DEFINE_OP (161, unused_161, NULL, NOP)
+   *
-  VM_DEFINE_OP (162, unused_162, NULL, NOP)
+   * Call the void-returning instrinsic with index IDX, passing SCM
+   * locals A and B as arguments.
+   */
+  VM_DEFINE_OP (160, call_scm_scm, "call-scm-scm", OP2 (X8_S12_S12, C32))
+    {
+      uint16_t a, b;
+      scm_t_scm_scm_intrinsic intrinsic;
+
+      UNPACK_12_12 (op, a, b);
+      intrinsic = intrinsics[ip[1]];
+
+      SYNC_IP ();
+      intrinsic (SP_REF (a), SP_REF (b));
+
+      NEXT (2);
+    }
+
+  /* call-scm-scm-scm a:8 b:8 c:8 IDX:32
+   *
+   * Call the void-returning instrinsic with index IDX, passing SCM
+   * locals A, B, and C as arguments.
+   */
+  VM_DEFINE_OP (161, call_scm_scm_scm, "call-scm-scm-scm", OP2 (X8_S8_S8_S8, C32))
+    {
+      uint8_t a, b, c;
+      scm_t_scm_scm_scm_intrinsic intrinsic;
+
+      UNPACK_8_8_8 (op, a, b, c);
+      intrinsic = intrinsics[ip[1]];
+
+      SYNC_IP ();
+      intrinsic (SP_REF (a), SP_REF (b), SP_REF (c));
+
+      NEXT (2);
+    }
+
+  /* call-scm-uimm-scm a:8 b:8 c:8 IDX:32
+   *
+   * Call the void-returning instrinsic with index IDX, passing SCM
+   * local A, uint8 B, and SCM local C as arguments.
+   */
+  VM_DEFINE_OP (162, call_scm_uimm_scm, "call-scm-uimm-scm", OP2 (X8_S8_C8_S8, C32))
+    {
+      uint8_t a, b, c;
+      scm_t_scm_uimm_scm_intrinsic intrinsic;
+
+      UNPACK_8_8_8 (op, a, b, c);
+      intrinsic = intrinsics[ip[1]];
+
+      SYNC_IP ();
+      intrinsic (SP_REF (a), b, SP_REF (c));
+
+      NEXT (2);
+    }
+
   VM_DEFINE_OP (163, unused_163, NULL, NOP)
   VM_DEFINE_OP (164, unused_164, NULL, NOP)
   VM_DEFINE_OP (165, unused_165, NULL, NOP)

module/system/vm/assembler.scm

@@ -101,6 +101,10 @@
             emit-undefined?
             emit-eof-object?
 
+            emit-null?
+            emit-false?
+            emit-nil?
+
             emit-untag-fixnum
             emit-tag-fixnum
             emit-untag-char
@@ -256,6 +260,25 @@
             emit-define!
             emit-current-module
 
+            ;; Intrinsics for use by the baseline compiler.
+            emit-$car
+            emit-$cdr
+            emit-$set-car!
+            emit-$set-cdr!
+            emit-$variable-ref
+            emit-$variable-set!
+            emit-$vector-length
+            emit-$vector-ref
+            emit-$vector-set!
+            emit-$vector-ref/immediate
+            emit-$vector-set!/immediate
+            emit-$allocate-struct
+            emit-$struct-vtable
+            emit-$struct-ref
+            emit-$struct-set!
+            emit-$struct-ref/immediate
+            emit-$struct-set!/immediate
+
             emit-cache-ref
             emit-cache-set!
 
@@ -1399,6 +1422,15 @@ returned instead."
 (define-syntax-rule (define-scm<-thread-intrinsic name)
   (define-macro-assembler (name asm dst)
     (emit-call-scm<-thread asm dst (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm-scm-intrinsic name)
+  (define-macro-assembler (name asm a b)
+    (emit-call-scm-scm asm a b (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm-uimm-scm-intrinsic name)
+  (define-macro-assembler (name asm a b c)
+    (emit-call-scm-uimm-scm asm a b c (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm-scm-scm-intrinsic name)
+  (define-macro-assembler (name asm a b c)
+    (emit-call-scm-scm-scm asm a b c (intrinsic-name->index 'name))))
 
 (define-scm<-scm-scm-intrinsic add)
 (define-scm<-scm-uimm-intrinsic add/immediate)
@@ -1464,6 +1496,24 @@ returned instead."
 (define-scm<-scm-scm-intrinsic define!)
 (define-scm<-thread-intrinsic current-module)
 
+(define-scm<-scm-intrinsic $car)
+(define-scm<-scm-intrinsic $cdr)
+(define-scm-scm-intrinsic $set-car!)
+(define-scm-scm-intrinsic $set-cdr!)
+(define-scm<-scm-intrinsic $variable-ref)
+(define-scm-scm-intrinsic $variable-set!)
+(define-scm<-scm-intrinsic $vector-length)
+(define-scm<-scm-scm-intrinsic $vector-ref)
+(define-scm-scm-scm-intrinsic $vector-set!)
+(define-scm<-scm-uimm-intrinsic $vector-ref/immediate)
+(define-scm-uimm-scm-intrinsic $vector-set!/immediate)
+(define-scm<-scm-scm-intrinsic $allocate-struct)
+(define-scm<-scm-intrinsic $struct-vtable)
+(define-scm<-scm-scm-intrinsic $struct-ref)
+(define-scm-scm-scm-intrinsic $struct-set!)
+(define-scm<-scm-uimm-intrinsic $struct-ref/immediate)
+(define-scm-uimm-scm-intrinsic $struct-set!/immediate)
+
 (define-macro-assembler (begin-program asm label properties)
   (emit-label asm label)
   (let ((meta (make-meta label properties (asm-start asm))))