diff options
| author | Andy Wingo <wingo@pobox.com> | 2018-05-01 07:00:37 +0200 |
|---|---|---|
| committer | Andy Wingo <wingo@pobox.com> | 2018-05-01 07:02:45 +0200 |
| commit | 1532b570e583cdc07734300d29c9e00022ba8ffd (patch) | |
| tree | 73feec984a25d0382ebceb0a5ea96d5f845043ac /libguile/intrinsics.c | |
| parent | e014bf3fc5578e3e0d4a0964ae5b4e8cb5c633c9 (diff) | |
| download | guile-1532b570e583cdc07734300d29c9e00022ba8ffd.tar.gz | |
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.
Diffstat (limited to 'libguile/intrinsics.c')
| -rw-r--r-- | libguile/intrinsics.c | 45 |
1 files changed, 45 insertions, 0 deletions
diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c index 4395148af..75a70fa3a 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", |