summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/intrinsics.h28
-rw-r--r--libguile/vm-engine.c38
-rw-r--r--libguile/vm.c1
-rw-r--r--module/language/bytecode.scm27
-rw-r--r--module/system/vm/assembler.scm66
5 files changed, 130 insertions, 30 deletions
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index c2805de90..4ed6c54da 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -23,22 +23,22 @@
#ifdef BUILDING_LIBGUILE
-typedef SCM (*scm_t_binary_scm_intrinsic) (SCM, SCM);
-typedef SCM (*scm_t_binary_uimm_intrinsic) (SCM, scm_t_uint8);
+typedef SCM (*scm_t_scm_from_scm_scm_intrinsic) (SCM, SCM);
+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(binary_uimm, add_immediate, "add/immediate", ADD_IMMEDIATE) \
- M(binary_scm, sub, "sub", SUB) \
- M(binary_uimm, sub_immediate, "sub/immediate", SUB_IMMEDIATE) \
- M(binary_scm, mul, "mul", MUL) \
- M(binary_scm, div, "div", DIV) \
- M(binary_scm, quo, "quo", QUO) \
- M(binary_scm, rem, "rem", REM) \
- M(binary_scm, mod, "mod", MOD) \
- M(binary_scm, logand, "logand", LOGAND) \
- M(binary_scm, logior, "logior", LOGIOR) \
- M(binary_scm, logxor, "logxor", LOGXOR) \
+ M(scm_from_scm_scm, add, "add", ADD) \
+ M(scm_from_scm_uimm, add_immediate, "add/immediate", ADD_IMMEDIATE) \
+ M(scm_from_scm_scm, sub, "sub", SUB) \
+ M(scm_from_scm_uimm, sub_immediate, "sub/immediate", SUB_IMMEDIATE) \
+ M(scm_from_scm_scm, mul, "mul", MUL) \
+ M(scm_from_scm_scm, div, "div", DIV) \
+ M(scm_from_scm_scm, quo, "quo", QUO) \
+ M(scm_from_scm_scm, rem, "rem", REM) \
+ M(scm_from_scm_scm, mod, "mod", MOD) \
+ M(scm_from_scm_scm, logand, "logand", LOGAND) \
+ M(scm_from_scm_scm, logior, "logior", LOGIOR) \
+ M(scm_from_scm_scm, logxor, "logxor", LOGXOR) \
/* Add new intrinsics here; also update scm_bootstrap_intrinsics. */
enum scm_vm_intrinsic
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 63f4b895e..c7407ef2f 100644
--- a/libguile/vm-engine.c
+++ b/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 (52, unused_52, NULL, NOP)
+ VM_DEFINE_OP (51, call_scm_from_scm_scm, "call-scm<-scm-scm", OP2 (X8_S8_S8_S8, C32) | OP_DST)
+ {
+ 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);
diff --git a/libguile/vm.c b/libguile/vm.c
index 0a20f11cf..2381a144e 100644
--- a/libguile/vm.c
+++ b/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"
diff --git a/module/language/bytecode.scm b/module/language/bytecode.scm
index b6be04178..e072a09bd 100644
--- a/module/language/bytecode.scm
+++ b/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))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 4ac435356..14a0a34d7 100644
--- a/module/system/vm/assembler.scm
+++ b/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))))