Compile some generic arithmetic to intrinsic calls

* libguile/intrinsics.h: Rename intrinsic types added in previous
  commit.
* libguile/vm-engine.c (call-scm<-scm-scm, call-scm<-scm-uimm): New
  instructions.
* libguile/vm.c: Include intrinsics.h.
* module/language/bytecode.scm
* module/language/bytecode.scm (*intrinsic-codes*, *intrinsic-names*):
  New internal definitions.
  (intrinsic-name->index, intrinsic-index->name): New exported
  definitions.
* module/system/vm/assembler.scm (encode-X8_S8_S8_S8-C32<-/shuffle):
  (encode-X8_S8_S8_C8-C32<-/shuffle): New shuffling encoders.
  (shuffling-encoder-name): Add case for new shuffling encoders.
  (define-scm<-scm-scm-intrinsic, define-scm<-scm-uimm-intrinsic): New
  helpers.  Define encoders for "add", etc.

libguile/intrinsics.h

@@ -23,22 +23,22 @@
 
 #ifdef BUILDING_LIBGUILE
 
-typedef SCM (*scm_t_binary_scm_intrinsic) (SCM, SCM);
+typedef SCM (*scm_t_scm_from_scm_scm_intrinsic) (SCM, SCM);
-typedef SCM (*scm_t_binary_uimm_intrinsic) (SCM, scm_t_uint8);
+typedef SCM (*scm_t_scm_from_scm_uimm_intrinsic) (SCM, scm_t_uint8);
 
 #define SCM_FOR_ALL_VM_INTRINSICS(M) \
-  M(binary_scm, add, "add", ADD) \
+  M(scm_from_scm_scm, add, "add", ADD) \
-  M(binary_uimm, add_immediate, "add/immediate", ADD_IMMEDIATE) \
+  M(scm_from_scm_uimm, add_immediate, "add/immediate", ADD_IMMEDIATE) \
-  M(binary_scm, sub, "sub", SUB) \
+  M(scm_from_scm_scm, sub, "sub", SUB) \
-  M(binary_uimm, sub_immediate, "sub/immediate", SUB_IMMEDIATE) \
+  M(scm_from_scm_uimm, sub_immediate, "sub/immediate", SUB_IMMEDIATE) \
-  M(binary_scm, mul, "mul", MUL) \
+  M(scm_from_scm_scm, mul, "mul", MUL) \
-  M(binary_scm, div, "div", DIV) \
+  M(scm_from_scm_scm, div, "div", DIV) \
-  M(binary_scm, quo, "quo", QUO) \
+  M(scm_from_scm_scm, quo, "quo", QUO) \
-  M(binary_scm, rem, "rem", REM) \
+  M(scm_from_scm_scm, rem, "rem", REM) \
-  M(binary_scm, mod, "mod", MOD) \
+  M(scm_from_scm_scm, mod, "mod", MOD) \
-  M(binary_scm, logand, "logand", LOGAND) \
+  M(scm_from_scm_scm, logand, "logand", LOGAND) \
-  M(binary_scm, logior, "logior", LOGIOR) \
+  M(scm_from_scm_scm, logior, "logior", LOGIOR) \
-  M(binary_scm, logxor, "logxor", LOGXOR) \
+  M(scm_from_scm_scm, logxor, "logxor", LOGXOR) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
 enum scm_vm_intrinsic

libguile/vm-engine.c

@@ -358,6 +358,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
   jump_table = jump_table_;
 #endif
 
+  void **intrinsics = (void**) &scm_vm_intrinsics;
+
   /* Load VM registers. */
   CACHE_REGISTER ();
 
@@ -1497,8 +1499,40 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (2);
     }
 
-  VM_DEFINE_OP (51, unused_51, NULL, NOP)
+  VM_DEFINE_OP (51, call_scm_from_scm_scm, "call-scm<-scm-scm", OP2 (X8_S8_S8_S8, C32) | OP_DST)
-  VM_DEFINE_OP (52, unused_52, NULL, NOP)
+    {
+      scm_t_uint8 dst, a, b;
+      SCM res;
+      scm_t_scm_from_scm_scm_intrinsic intrinsic;
+
+      UNPACK_8_8_8 (op, dst, a, b);
+      intrinsic = intrinsics[ip[1]];
+
+      SYNC_IP ();
+      res = intrinsic (SP_REF (a), SP_REF (b));
+      CACHE_SP ();
+      SP_SET (dst, res);
+
+      NEXT (2);
+    }
+
+  VM_DEFINE_OP (52, call_scm_from_scm_uimm, "call-scm<-scm-uimm", OP2 (X8_S8_S8_C8, C32) | OP_DST)
+    {
+      scm_t_uint8 dst, a, b;
+      SCM res;
+      scm_t_scm_from_scm_uimm_intrinsic intrinsic;
+
+      UNPACK_8_8_8 (op, dst, a, b);
+      intrinsic = intrinsics[ip[1]];
+
+      SYNC_IP ();
+      res = intrinsic (SP_REF (a), b);
+      CACHE_SP ();
+      SP_SET (dst, res);
+
+      NEXT (2);
+    }
+
   VM_DEFINE_OP (53, unused_53, NULL, NOP)
     {
       vm_error_bad_instruction (op);

libguile/vm.c

@@ -43,6 +43,7 @@
 #include "libguile/frames.h"
 #include "libguile/gc-inline.h"
 #include "libguile/instructions.h"
+#include "libguile/intrinsics.h"
 #include "libguile/loader.h"
 #include "libguile/programs.h"
 #include "libguile/simpos.h"

module/language/bytecode.scm

@@ -1,6 +1,6 @@
 ;;; Bytecode
 
-;; Copyright (C) 2013, 2017 Free Software Foundation, Inc.
+;; Copyright (C) 2013, 2017, 2018 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
@@ -24,12 +24,16 @@
   #:export (instruction-list
             instruction-arity
             builtin-name->index
-            builtin-index->name))
+            builtin-index->name
+            intrinsic-name->index
+            intrinsic-index->name))
 
 (load-extension (string-append "libguile-" (effective-version))
                 "scm_init_instructions")
 (load-extension (string-append "libguile-" (effective-version))
                 "scm_init_vm_builtins")
+(load-extension (string-append "libguile-" (effective-version))
+                "scm_init_intrinsics")
 
 (define (compute-instruction-arity name args)
   (define (first-word-arity word)
@@ -104,3 +108,22 @@
 
 (define (instruction-arity name)
   (hashq-ref (force *instruction-arities*) name))
+
+(define *intrinsic-codes*
+  (delay (let ((tab (make-hash-table)))
+           (for-each (lambda (pair)
+                       (hashv-set! tab (car pair) (cdr pair)))
+                     (intrinsic-list))
+           tab)))
+
+(define *intrinsic-names*
+  (delay (let ((tab (make-hash-table)))
+           (hash-for-each (lambda (k v) (hashq-set! tab v k))
+                          (force *intrinsic-codes*))
+           tab)))
+
+(define (intrinsic-name->index name)
+  (hashq-ref (force *intrinsic-codes*) name))
+
+(define (intrinsic-index->name index)
+  (hashv-ref (force *intrinsic-names*) index))

module/system/vm/assembler.scm

@@ -179,6 +179,20 @@
             emit-f32-set!
             emit-f64-set!
 
+            ;; Intrinsics.
+            emit-add
+            emit-add/immediate
+            emit-sub
+            emit-sub/immediate
+            emit-mul
+            emit-div
+            emit-quo
+            emit-rem
+            emit-mod
+            emit-logand
+            emit-logior
+            emit-logxor
+
             emit-call
             emit-call-label
             emit-tail-call
@@ -219,15 +233,6 @@
             emit-string->number
             emit-string->symbol
             emit-symbol->keyword
-            emit-add
-            emit-add/immediate
-            emit-sub
-            emit-sub/immediate
-            emit-mul
-            emit-div
-            emit-quo
-            emit-rem
-            emit-mod
             emit-lsh
             emit-rsh
             emit-lsh/immediate
@@ -242,9 +247,6 @@
             emit-uadd/immediate
             emit-usub/immediate
             emit-umul/immediate
-            emit-logand
-            emit-logior
-            emit-logxor
             emit-logsub
             emit-ulogand
             emit-ulogior
@@ -871,6 +873,24 @@ later by the linker."
     (emit-push asm a)
     (encode-X8_S8_C8_S8 asm 0 const 0 opcode)
     (emit-pop asm dst))))
+(define (encode-X8_S8_S8_S8-C32<-/shuffle asm dst a b c32 opcode)
+  (cond
+   ((< (logior dst a b) (ash 1 8))
+    (encode-X8_S8_S8_S8-C32 asm dst a b c32 opcode))
+   (else
+    (emit-push asm a)
+    (emit-push asm (1+ b))
+    (encode-X8_S8_S8_S8-C32 asm 1 1 0 c32 opcode)
+    (emit-drop asm 1)
+    (emit-pop asm dst))))
+(define (encode-X8_S8_S8_C8-C32<-/shuffle asm dst a const c32 opcode)
+  (cond
+   ((< (logior dst a) (ash 1 8))
+    (encode-X8_S8_S8_C8-C32 asm dst a const c32 opcode))
+   (else
+    (emit-push asm a)
+    (encode-X8_S8_S8_C8-C32 asm 0 0 const c32 opcode)
+    (emit-pop asm dst))))
 
 (eval-when (expand)
   (define (id-append ctx a b)
@@ -889,6 +909,8 @@ later by the linker."
       (('! 'X8_S8_S8_S8)         #'encode-X8_S8_S8_S8!/shuffle)
       (('<- 'X8_S8_S8_S8)        #'encode-X8_S8_S8_S8<-/shuffle)
       (('<- 'X8_S8_S8_C8)        #'encode-X8_S8_S8_C8<-/shuffle)
+      (('<- 'X8_S8_S8_S8 'C32)   #'encode-X8_S8_S8_S8-C32<-/shuffle)
+      (('<- 'X8_S8_S8_C8 'C32)   #'encode-X8_S8_S8_C8-C32<-/shuffle)
       (('! 'X8_S8_C8_S8)         #'encode-X8_S8_C8_S8!/shuffle)
       (('<- 'X8_S8_C8_S8)        #'encode-X8_S8_C8_S8<-/shuffle)
       (else (encoder-name operands))))
@@ -1241,6 +1263,26 @@ returned instead."
 
 (visit-heap-tags define-heap-tag=?-macro-assembler)
 
+(define-syntax-rule (define-scm<-scm-scm-intrinsic name)
+  (define-macro-assembler (name asm dst a b)
+    (emit-call-scm<-scm-scm asm dst a b (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-scm-uimm-intrinsic name)
+  (define-macro-assembler (name asm dst a b)
+    (emit-call-scm<-scm-uimm asm dst a b (intrinsic-name->index 'name))))
+
+(define-scm<-scm-scm-intrinsic add)
+(define-scm<-scm-uimm-intrinsic add/immediate)
+(define-scm<-scm-scm-intrinsic sub)
+(define-scm<-scm-uimm-intrinsic sub/immediate)
+(define-scm<-scm-scm-intrinsic mul)
+(define-scm<-scm-scm-intrinsic div)
+(define-scm<-scm-scm-intrinsic quo)
+(define-scm<-scm-scm-intrinsic rem)
+(define-scm<-scm-scm-intrinsic mod)
+(define-scm<-scm-scm-intrinsic logand)
+(define-scm<-scm-scm-intrinsic logior)
+(define-scm<-scm-scm-intrinsic logxor)
+
 (define-macro-assembler (begin-program asm label properties)
   (emit-label asm label)
   (let ((meta (make-meta label properties (asm-start asm))))