mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

lsh, rsh etc are intrinsics

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2018-05-01 07:00:37 +02:00
parent e014bf3fc5
commit 1532b570e5
5 changed files with 88 additions and 33 deletions
Download patch file Download diff file Expand all files Collapse all files

45
libguile/intrinsics.c
View file

@ -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",

5
libguile/intrinsics.h
View file

@ -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

53
libguile/vm-engine.c
View file

@ -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;

3
module/language/cps/reify-primitives.scm
View file

@ -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)))

15
module/system/vm/assembler.scm
View file

@ -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)