diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c index 0814b0d22..d8b58ad25 100644 --- a/libguile/intrinsics.c +++ b/libguile/intrinsics.c @@ -71,6 +71,15 @@ string_to_number (SCM str) return scm_string_to_number (str, SCM_UNDEFINED /* radix = 10 */); } +static scm_t_uint64 +scm_to_uint64_truncate (SCM x) +{ + if (SCM_I_INUMP (x)) + return (scm_t_uint64) SCM_I_INUM (x); + else + return scm_to_uint64 (scm_logand (x, scm_from_uint64 ((scm_t_uint64) -1))); +} + void scm_bootstrap_intrinsics (void) { @@ -92,6 +101,9 @@ scm_bootstrap_intrinsics (void) scm_vm_intrinsics.symbol_to_keyword = scm_symbol_to_keyword; scm_vm_intrinsics.class_of = scm_class_of; scm_vm_intrinsics.scm_to_f64 = scm_to_double; + scm_vm_intrinsics.scm_to_u64 = scm_to_uint64; + scm_vm_intrinsics.scm_to_u64_truncate = scm_to_uint64_truncate; + scm_vm_intrinsics.scm_to_s64 = scm_to_int64; scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, "scm_init_intrinsics", diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h index b14bb4761..aea73dd07 100644 --- a/libguile/intrinsics.h +++ b/libguile/intrinsics.h @@ -28,6 +28,8 @@ typedef SCM (*scm_t_scm_from_scm_uimm_intrinsic) (SCM, scm_t_uint8); typedef void (*scm_t_scm_u64_u64_intrinsic) (SCM, scm_t_uint64, scm_t_uint64); typedef SCM (*scm_t_scm_from_scm_intrinsic) (SCM); typedef double (*scm_t_f64_from_scm_intrinsic) (SCM); +typedef scm_t_uint64 (*scm_t_u64_from_scm_intrinsic) (SCM); +typedef scm_t_int64 (*scm_t_s64_from_scm_intrinsic) (SCM); #define SCM_FOR_ALL_VM_INTRINSICS(M) \ M(scm_from_scm_scm, add, "add", ADD) \ @@ -48,6 +50,9 @@ typedef double (*scm_t_f64_from_scm_intrinsic) (SCM); M(scm_from_scm, symbol_to_keyword, "symbol->keyword", SYMBOL_TO_KEYWORD) \ M(scm_from_scm, class_of, "class-of", CLASS_OF) \ M(f64_from_scm, scm_to_f64, "scm->f64", SCM_TO_F64) \ + M(u64_from_scm, scm_to_u64, "scm->u64", SCM_TO_U64) \ + M(u64_from_scm, scm_to_u64_truncate, "scm->u64/truncate", SCM_TO_U64_TRUNCATE) \ + M(s64_from_scm, scm_to_s64, "scm->s64", SCM_TO_S64) \ /* 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 2b274aa71..0e8929240 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -1580,10 +1580,21 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (2); } - VM_DEFINE_OP (56, unused_56, NULL, NOP) + VM_DEFINE_OP (56, call_u64_from_scm, "call-u64<-scm", OP2 (X8_S12_S12, C32) | OP_DST) { - vm_error_bad_instruction (op); - abort (); /* never reached */ + scm_t_uint8 dst, src; + scm_t_uint64 res; + scm_t_u64_from_scm_intrinsic intrinsic; + + UNPACK_12_12 (op, dst, src); + intrinsic = intrinsics[ip[1]]; + + SYNC_IP (); + res = intrinsic (SP_REF (src)); + CACHE_SP (); + SP_SET_U64 (dst, res); + + NEXT (2); } @@ -2148,7 +2159,23 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (2); } - VM_DEFINE_OP (77, unused_77, NULL, NOP) + VM_DEFINE_OP (77, call_s64_from_scm, "call-s64<-scm", OP2 (X8_S12_S12, C32) | OP_DST) + { + scm_t_uint8 dst, src; + scm_t_int64 res; + scm_t_s64_from_scm_intrinsic intrinsic; + + UNPACK_12_12 (op, dst, src); + intrinsic = intrinsics[ip[1]]; + + SYNC_IP (); + res = intrinsic (SP_REF (src)); + CACHE_SP (); + SP_SET_S64 (dst, res); + + NEXT (2); + } + VM_DEFINE_OP (78, unused_78, NULL, NOP) VM_DEFINE_OP (79, unused_79, NULL, NOP) VM_DEFINE_OP (80, unused_80, NULL, NOP) @@ -2328,11 +2355,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (0); } - /* scm->u64 dst:12 src:12 - * - * Unpack an unsigned 64-bit integer from SRC and place it in DST. - */ - VM_DEFINE_OP (143, scm_to_u64, "scm->u64", OP1 (X8_S12_S12) | OP_DST) + VM_DEFINE_OP (143, unused_143, NULL, NOP) { scm_t_uint16 dst, src; UNPACK_12_12 (op, dst, src); @@ -2491,11 +2514,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (3); } - /* scm->s64 dst:12 src:12 - * - * Unpack a signed 64-bit integer from SRC and place it in DST. - */ - VM_DEFINE_OP (157, scm_to_s64, "scm->s64", OP1 (X8_S12_S12) | OP_DST) + VM_DEFINE_OP (157, unused_157, NULL, NOP) { scm_t_uint16 dst, src; UNPACK_12_12 (op, dst, src); @@ -2647,13 +2666,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, NEXT (1); } - /* scm->u64/truncate dst:12 src:12 - * - * Unpack an exact integer from SRC and place it in the unsigned - * 64-bit register DST, truncating any high bits. If the number in - * SRC is negative, all the high bits will be set. - */ - VM_DEFINE_OP (167, scm_to_u64_truncate, "scm->u64/truncate", OP1 (X8_S12_S12) | OP_DST) + VM_DEFINE_OP (167, unused_167, NULL, NOP) { scm_t_uint16 dst, src; SCM x; diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index c1ebd1cf3..66d00d77d 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -230,6 +230,9 @@ symbol->keyword class-of scm->f64 + scm->u64 + scm->u64/truncate + scm->s64 u64->s64 s64->u64 cache-current-module! diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 88f713a8d..e47e6250f 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -201,6 +201,9 @@ emit-symbol->keyword emit-class-of emit-scm->f64 + emit-scm->u64 + emit-scm->u64/truncate + emit-scm->s64 emit-call emit-call-label @@ -263,11 +266,8 @@ emit-ulsh/immediate emit-make-array emit-load-f64 - emit-scm->u64 - emit-scm->u64/truncate emit-load-u64 emit-u64->scm - emit-scm->s64 emit-load-s64 emit-s64->scm emit-make-atomic-box @@ -1296,6 +1296,12 @@ returned instead." (define-syntax-rule (define-f64<-scm-intrinsic name) (define-macro-assembler (name asm dst src) (emit-call-f64<-scm asm dst src (intrinsic-name->index 'name)))) +(define-syntax-rule (define-u64<-scm-intrinsic name) + (define-macro-assembler (name asm dst src) + (emit-call-u64<-scm asm dst src (intrinsic-name->index 'name)))) +(define-syntax-rule (define-s64<-scm-intrinsic name) + (define-macro-assembler (name asm dst src) + (emit-call-s64<-scm asm dst src (intrinsic-name->index 'name)))) (define-scm<-scm-scm-intrinsic add) (define-scm<-scm-uimm-intrinsic add/immediate) @@ -1315,6 +1321,9 @@ returned instead." (define-scm<-scm-intrinsic symbol->keyword) (define-scm<-scm-intrinsic class-of) (define-f64<-scm-intrinsic scm->f64) +(define-u64<-scm-intrinsic scm->u64) +(define-u64<-scm-intrinsic scm->u64/truncate) +(define-s64<-scm-intrinsic scm->s64) (define-macro-assembler (begin-program asm label properties) (emit-label asm label)