[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/16: lsh, rsh etc are intrinsics
From: |
Andy Wingo |
Subject: |
[Guile-commits] 01/16: lsh, rsh etc are intrinsics |
Date: |
Mon, 14 May 2018 10:48:34 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 1532b570e583cdc07734300d29c9e00022ba8ffd
Author: Andy Wingo <address@hidden>
Date: Tue May 1 07:00:37 2018 +0200
lsh, rsh etc are intrinsics
* libguile/intrinsics.c (lsh, rsh, lsh_immediate, rsh_immediate): New
intrinsics.
(scm_bootstrap_intrinsics): Wire up the intrinsics.
* libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS): Add new
intrinsics.
* libguile/vm-engine.c (call-scm<-scm-u64): New intrinsic caller.
(lsh, rsh, lsh/immediate, rsh/immediate): Disable.
* module/language/cps/reify-primitives.scm (compute-known-primitives):
Add new intrinsics.
* module/system/vm/assembler.scm: Adapt assemblers for new intrinsics.
---
libguile/intrinsics.c | 45 +++++++++++++++++++++++++++
libguile/intrinsics.h | 5 +++
libguile/vm-engine.c | 53 +++++++++++++++-----------------
module/language/cps/reify-primitives.scm | 3 +-
module/system/vm/assembler.scm | 15 ++++++---
5 files changed, 88 insertions(+), 33 deletions(-)
diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index 4395148..75a70fa 100644
--- a/libguile/intrinsics.c
+++ b/libguile/intrinsics.c
@@ -162,6 +162,47 @@ pop_dynamic_state (scm_i_thread *thread)
thread->dynamic_state);
}
+static SCM
+lsh (SCM a, scm_t_uint64 b)
+{
+ if (SCM_LIKELY (SCM_I_INUMP (a))
+ && b < (scm_t_uint64) (SCM_I_FIXNUM_BIT - 1)
+ && ((scm_t_bits)
+ (SCM_SRS (SCM_I_INUM (a), (SCM_I_FIXNUM_BIT-1 - b)) + 1)
+ <= 1))
+ {
+ scm_t_signed_bits nn = SCM_I_INUM (a);
+ return SCM_I_MAKINUM (nn < 0 ? -(-nn << b) : (nn << b));
+ }
+ else
+ return scm_ash (a, scm_from_uint64 (b));
+}
+
+static SCM
+rsh (SCM a, scm_t_uint64 b)
+{
+ if (SCM_LIKELY (SCM_I_INUMP (a)))
+ {
+ if (b > (scm_t_uint64) (SCM_I_FIXNUM_BIT - 1))
+ b = SCM_I_FIXNUM_BIT - 1;
+ return SCM_I_MAKINUM (SCM_SRS (SCM_I_INUM (a), b));
+ }
+ else
+ return scm_ash (a, scm_difference (SCM_INUM0, scm_from_uint64 (b)));
+}
+
+static SCM
+lsh_immediate (SCM a, scm_t_uint8 b)
+{
+ return lsh (a, b);
+}
+
+static SCM
+rsh_immediate (SCM a, scm_t_uint8 b)
+{
+ return rsh (a, b);
+}
+
void
scm_bootstrap_intrinsics (void)
{
@@ -197,6 +238,10 @@ scm_bootstrap_intrinsics (void)
scm_vm_intrinsics.fluid_set_x = fluid_set_x;
scm_vm_intrinsics.push_dynamic_state = push_dynamic_state;
scm_vm_intrinsics.pop_dynamic_state = pop_dynamic_state;
+ scm_vm_intrinsics.lsh = lsh;
+ scm_vm_intrinsics.rsh = rsh;
+ scm_vm_intrinsics.lsh_immediate = lsh_immediate;
+ scm_vm_intrinsics.rsh_immediate = rsh_immediate;
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_intrinsics",
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index b845769..419c0c0 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -36,6 +36,7 @@ typedef void (*scm_t_thread_intrinsic) (scm_i_thread*);
typedef void (*scm_t_thread_scm_intrinsic) (scm_i_thread*, SCM);
typedef void (*scm_t_thread_scm_scm_intrinsic) (scm_i_thread*, SCM, SCM);
typedef SCM (*scm_t_scm_from_thread_scm_intrinsic) (scm_i_thread*, SCM);
+typedef SCM (*scm_t_scm_from_scm_u64_intrinsic) (SCM, scm_t_uint64);
#define SCM_FOR_ALL_VM_INTRINSICS(M) \
M(scm_from_scm_scm, add, "add", ADD) \
@@ -70,6 +71,10 @@ typedef SCM (*scm_t_scm_from_thread_scm_intrinsic)
(scm_i_thread*, SCM);
M(thread_scm_scm, fluid_set_x, "fluid-set!", FLUID_SET_X) \
M(thread_scm, push_dynamic_state, "push-dynamic-state", PUSH_DYNAMIC_STATE) \
M(thread, pop_dynamic_state, "pop-dynamic-state", POP_DYNAMIC_STATE) \
+ M(scm_from_scm_u64, lsh, "lsh", LSH) \
+ M(scm_from_scm_u64, rsh, "rsh", RSH) \
+ M(scm_from_scm_uimm, lsh_immediate, "lsh/immediate", LSH_IMMEDIATE) \
+ M(scm_from_scm_uimm, rsh_immediate, "rsh/immediate", RSH_IMMEDIATE) \
/* 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 3dac7d0..2d74787 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -2209,7 +2209,24 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
NEXT (2);
}
- VM_DEFINE_OP (91, unused_91, NULL, NOP)
+ VM_DEFINE_OP (91, call_scm_from_scm_u64, "call-scm<-scm-u64", OP2
(X8_S8_S8_S8, C32))
+ {
+ scm_t_uint8 dst, a, b;
+ SCM res;
+ scm_t_scm_from_scm_u64_intrinsic intrinsic;
+
+ UNPACK_8_8_8 (op, dst, a, b);
+ intrinsic = intrinsics[ip[1]];
+
+ SYNC_IP ();
+ res = intrinsic (SP_REF (a), SP_REF_U64 (b));
+ CACHE_SP ();
+
+ SP_SET (dst, res);
+
+ NEXT (2);
+ }
+
VM_DEFINE_OP (92, unused_92, NULL, NOP)
VM_DEFINE_OP (93, unused_93, NULL, NOP)
VM_DEFINE_OP (94, unused_94, NULL, NOP)
@@ -3345,15 +3362,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
abort (); /* never reached */
}
- /* Temporary instructions down here, while we incrementally proceed
- with instruction explosion. */
-
- /* lsh dst:8 a:8 b:8
- *
- * Shift A left by B bits, and place the result in DST. B is a U64
- * value.
- */
- VM_DEFINE_OP (252, lsh, "lsh", OP1 (X8_S8_S8_S8) | OP_DST)
+ VM_DEFINE_OP (252, unused_252, NULL, NOP)
{
scm_t_uint8 dst, x, y;
SCM a, result;
@@ -3383,12 +3392,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
SP_SET (dst, result);
NEXT (1);
}
- /* rsh dst:8 a:8 b:8
- *
- * Shift A right by B bits, and place the result in DST. B is a U64
- * value.
- */
- VM_DEFINE_OP (253, rsh, "rsh", OP1 (X8_S8_S8_S8) | OP_DST)
+
+ VM_DEFINE_OP (253, unused_253, NULL, NOP)
{
scm_t_uint8 dst, x, y;
SCM a, result;
@@ -3415,12 +3420,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
SP_SET (dst, result);
NEXT (1);
}
- /* lsh/immediate dst:8 a:8 b:8
- *
- * Shift A left by B bits, and place the result in DST. B is an
- * immediate unsigned integer.
- */
- VM_DEFINE_OP (254, lsh_immediate, "lsh/immediate", OP1 (X8_S8_S8_C8) |
OP_DST)
+
+ VM_DEFINE_OP (254, unused_254, NULL, NOP)
{
scm_t_uint8 dst, x, y;
SCM a, result;
@@ -3450,12 +3451,8 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
SP_SET (dst, result);
NEXT (1);
}
- /* rsh dst:8 a:8 b:8
- *
- * Shift A right by B bits, and place the result in DST. B is an
- * immediate unsigned integer.
- */
- VM_DEFINE_OP (255, rsh_immediate, "rsh/immediate", OP1 (X8_S8_S8_C8) |
OP_DST)
+
+ VM_DEFINE_OP (255, unused_255, NULL, NOP)
{
scm_t_uint8 dst, x, y;
SCM a, result;
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index 1d354d5..eec757b 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -238,7 +238,8 @@
cached-module-box
wind unwind
push-fluid pop-fluid fluid-ref fluid-set!
- push-dynamic-state pop-dynamic-state))
+ push-dynamic-state pop-dynamic-state
+ lsh rsh lsh/immediate rsh/immediate))
(let ((table (make-hash-table)))
(for-each
(match-lambda ((inst . _) (hashq-set! table inst #t)))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 2bbcdd2..5943429 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -220,6 +220,10 @@
emit-fluid-set!
emit-push-dynamic-state
emit-pop-dynamic-state
+ emit-lsh
+ emit-rsh
+ emit-lsh/immediate
+ emit-rsh/immediate
emit-call
emit-call-label
@@ -247,10 +251,6 @@
emit-module-box
emit-prompt
emit-current-thread
- emit-lsh
- emit-rsh
- emit-lsh/immediate
- emit-rsh/immediate
emit-fadd
emit-fsub
emit-fmul
@@ -1333,6 +1333,9 @@ returned instead."
(define-syntax-rule (define-scm<-thread-scm-intrinsic name)
(define-macro-assembler (name asm dst src)
(emit-call-scm<-thread-scm asm dst src (intrinsic-name->index 'name))))
+(define-syntax-rule (define-scm<-scm-u64-intrinsic name)
+ (define-macro-assembler (name asm dst a b)
+ (emit-call-scm<-scm-u64 asm dst a b (intrinsic-name->index 'name))))
(define-scm<-scm-scm-intrinsic add)
(define-scm<-scm-uimm-intrinsic add/immediate)
@@ -1366,6 +1369,10 @@ returned instead."
(define-thread-scm-scm-intrinsic fluid-set!)
(define-thread-scm-intrinsic push-dynamic-state)
(define-thread-intrinsic pop-dynamic-state)
+(define-scm<-scm-u64-intrinsic lsh)
+(define-scm<-scm-u64-intrinsic rsh)
+(define-scm<-scm-uimm-intrinsic lsh/immediate)
+(define-scm<-scm-uimm-intrinsic rsh/immediate)
(define-macro-assembler (begin-program asm label properties)
(emit-label asm label)
- [Guile-commits] 08/16: Add scm_maybe_resolve_module, (continued)
- [Guile-commits] 08/16: Add scm_maybe_resolve_module, Andy Wingo, 2018/05/14
- [Guile-commits] 07/16: Mark call-scm<-scm-u64 as defining a result, Andy Wingo, 2018/05/14
- [Guile-commits] 12/16: Instruction explosion for cache-current-module, cached-toplevel-box, Andy Wingo, 2018/05/14
- [Guile-commits] 10/16: Add cache-ref, cache-set! macro-instructions, Andy Wingo, 2018/05/14
- [Guile-commits] 03/16: VM calls out to heap-numbers-equal? through intrinsics, Andy Wingo, 2018/05/14
- [Guile-commits] 15/16: Use intrinsics for top-level refs outside captured scopes, Andy Wingo, 2018/05/14
- [Guile-commits] 16/16: Remove implementations of now-unused toplevel-box et al instructions, Andy Wingo, 2018/05/14
- [Guile-commits] 13/16: Remove backend support for cached-module-box et al., Andy Wingo, 2018/05/14
- [Guile-commits] 11/16: Instruction explosion for cached-module-box, Andy Wingo, 2018/05/14
- [Guile-commits] 09/16: Add intrinsics for module operations, Andy Wingo, 2018/05/14
- [Guile-commits] 01/16: lsh, rsh etc are intrinsics,
Andy Wingo <=
- [Guile-commits] 14/16: Compile "define!" via intrinsic, Andy Wingo, 2018/05/14