From de42f120999d3ca745ecec347ca8dfda7f12c181 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 5 Jun 2019 22:23:46 -0400 Subject: [PATCH] DRAFT: Change f64->scm into an intrinsic. --- libguile/intrinsics.c | 1 + libguile/intrinsics.h | 2 ++ libguile/jit.c | 20 ++++++++++++++ libguile/vm-engine.c | 26 ++++++++++++++++++- module/language/cps/compile-bytecode.scm | 2 ++ module/language/cps/reify-primitives.scm | 33 +----------------------- module/system/vm/assembler.scm | 5 ++++ 7 files changed, 56 insertions(+), 33 deletions(-) diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c index ab6b6a872..d527e0407 100644 --- a/libguile/intrinsics.c +++ b/libguile/intrinsics.c @@ -459,6 +459,7 @@ 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.f64_to_scm = scm_from_double; #if INDIRECT_INT64_INTRINSICS scm_vm_intrinsics.scm_to_u64 = indirect_scm_to_uint64; scm_vm_intrinsics.scm_to_u64_truncate = indirect_scm_to_uint64_truncate; diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h index 2c1b53abc..306d269d0 100644 --- a/libguile/intrinsics.h +++ b/libguile/intrinsics.h @@ -34,6 +34,7 @@ typedef SCM (*scm_t_scm_from_scm_uimm_intrinsic) (SCM, uint8_t); typedef void (*scm_t_scm_sz_u32_intrinsic) (SCM, size_t, uint32_t); typedef SCM (*scm_t_scm_from_scm_intrinsic) (SCM); typedef double (*scm_t_f64_from_scm_intrinsic) (SCM); +typedef SCM (*scm_t_scm_from_f64_intrinsic) (double); /* If we don't have 64-bit registers, the intrinsics will take and return 64-bit values by reference. */ @@ -161,6 +162,7 @@ typedef uint32_t* scm_t_vcode_intrinsic; M(thread_u8_scm_sp_vra_mra, push_prompt, "push-prompt", PUSH_PROMPT) \ M(thread_scm, unpack_values_object, "unpack-values-object", UNPACK_VALUES_OBJECT) \ M(vcode, handle_interrupt_code, "%handle-interrupt-code", HANDLE_INTERRUPT_CODE) \ + M(scm_from_f64, f64_to_scm, "f64->scm", F64_TO_SCM) \ /* Add new intrinsics here; also update scm_bootstrap_intrinsics. */ enum scm_vm_intrinsic diff --git a/libguile/jit.c b/libguile/jit.c index 82c62520b..95ff7fcc9 100644 --- a/libguile/jit.c +++ b/libguile/jit.c @@ -982,6 +982,14 @@ emit_sp_set_sz (scm_jit_state *j, uint32_t dst, jit_gpr_t src) } } +static jit_operand_t +sp_f64_operand (scm_jit_state *j, uint32_t slot) +{ + ASSERT_HAS_REGISTER_STATE (SP_IN_REGISTER); + + return jit_operand_mem (JIT_OPERAND_ABI_DOUBLE, SP, 8 * slot); +} + static jit_operand_t sp_u64_operand (scm_jit_state *j, uint32_t slot) { @@ -2435,6 +2443,18 @@ compile_call_s64_from_scm (scm_jit_state *j, uint16_t dst, uint16_t a, uint32_t compile_call_u64_from_scm (j, dst, a, idx); } +static void +compile_call_scm_from_f64 (scm_jit_state *j, uint16_t dst, uint16_t src, uint32_t idx) +{ + void *intrinsic = ((void **) &scm_vm_intrinsics)[idx]; + + emit_store_current_ip (j, T0); + emit_call_1 (j, intrinsic, sp_f64_operand (j, src)); + emit_retval (j, T0); + emit_reload_sp (j); + emit_sp_set_scm (j, dst, T0); +} + static void compile_call_scm_from_u64 (scm_jit_state *j, uint16_t dst, uint16_t src, uint32_t idx) { diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index f2dcc9124..fd8a60419 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3231,7 +3231,31 @@ VM_NAME (scm_thread *thread) VM_DEFINE_OP (153, f64_set, "f64-set!", OP1 (X8_S8_S8_S8)) PTR_SET (double, F64); - VM_DEFINE_OP (154, unused_154, NULL, NOP) + /* call-scm<-f64 dst:12 a:12 IDX:32 + * + * Call the SCM-returning instrinsic with index IDX, passing the + * f64 local A as argument. Place the SCM result in DST. + */ + VM_DEFINE_OP (154, call_scm_from_f64, "call-scm<-f64", DOP2 (X8_S12_S12, C32)) + { + uint16_t dst, src; + SCM res; + scm_t_scm_from_f64_intrinsic intrinsic; + + UNPACK_12_12 (op, dst, src); + intrinsic = intrinsics[ip[1]]; + + SYNC_IP (); + res = intrinsic (SP_REF_F64 (src)); + SP_SET (dst, res); + + /* No CACHE_SP () after the intrinsic, as the indirect variants + pass stack pointers directly; stack relocation during this kind + of intrinsic is not supported! */ + + NEXT (2); + } + VM_DEFINE_OP (155, unused_155, NULL, NOP) VM_DEFINE_OP (156, unused_156, NULL, NOP) VM_DEFINE_OP (157, unused_157, NULL, NOP) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 15c0ade5e..fdf898dee 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -217,6 +217,8 @@ (emit-scm->f64 asm (from-sp dst) (from-sp (slot src)))) (($ $primcall 'load-f64 val ()) (emit-load-f64 asm (from-sp dst) val)) + (($ $primcall 'f64->scm #f (src)) + (emit-f64->scm asm (from-sp dst) (from-sp (slot src)))) (($ $primcall 'scm->u64 #f (src)) (emit-scm->u64 asm (from-sp dst) (from-sp (slot src)))) (($ $primcall 'scm->u64/truncate #f (src)) diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index 6ec90299e..9305fb446 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -323,7 +323,7 @@ string->symbol symbol->keyword class-of - scm->f64 + scm->f64 f64->scm s64->u64 s64->scm scm->s64 u64->s64 u64->scm scm->u64 scm->u64/truncate wind unwind @@ -368,37 +368,6 @@ ($ $continue k src ($ $primcall 'call-thunk/no-inline #f (proc)))) (with-cps cps (setk label ($kargs names vars ($continue k src ($call proc ())))))) - (($ $kargs names vars - ($ $continue k src ($ $primcall 'f64->scm #f (f64)))) - (with-cps cps - (letv scm tag ptr uidx) - (letk kdone ($kargs () () - ($continue k src ($values (scm))))) - (letk kinit ($kargs ('uidx) (uidx) - ($continue kdone src - ($primcall 'f64-set! 'flonum (scm ptr uidx f64))))) - (letk kidx ($kargs ('ptr) (ptr) - ($continue kinit src ($primcall 'load-u64 0 ())))) - (letk kptr ($kargs () () - ($continue kidx src - ($primcall 'tail-pointer-ref/immediate - `(flonum . ,(match (target-word-size) - (4 2) - (8 1))) - (scm))))) - (letk ktag1 ($kargs ('tag) (tag) - ($continue kptr src - ($primcall 'word-set!/immediate '(flonum . 0) (scm tag))))) - (letk ktag0 ($kargs ('scm) (scm) - ($continue ktag1 src - ($primcall 'load-u64 %tc16-flonum ())))) - (setk label ($kargs names vars - ($continue ktag0 src - ($primcall 'allocate-words/immediate - `(flonum . ,(match (target-word-size) - (4 4) - (8 2))) - ())))))) (($ $kargs names vars ($ $continue k src ($ $primcall 'u64->scm/unlikely #f (u64)))) (with-cps cps diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index cfda4f9cb..a45ded8a5 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -210,6 +210,7 @@ emit-scm->u64 emit-scm->u64/truncate emit-scm->s64 + emit-f64->scm emit-u64->scm emit-s64->scm emit-wind @@ -1336,6 +1337,9 @@ returned instead." (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-syntax-rule (define-scm<-f64-intrinsic name) + (define-macro-assembler (name asm dst src) + (emit-call-scm<-f64 asm dst src (intrinsic-name->index 'name)))) (define-syntax-rule (define-scm<-u64-intrinsic name) (define-macro-assembler (name asm dst src) (emit-call-scm<-u64 asm dst src (intrinsic-name->index 'name)))) @@ -1386,6 +1390,7 @@ returned instead." (define-u64<-scm-intrinsic scm->u64) (define-u64<-scm-intrinsic scm->u64/truncate) (define-s64<-scm-intrinsic scm->s64) +(define-scm<-f64-intrinsic f64->scm) (define-scm<-u64-intrinsic u64->scm) (define-scm<-s64-intrinsic s64->scm) (define-thread-scm-scm-intrinsic wind)