mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 04:10:18 +02:00
DRAFT: Change f64->scm into an intrinsic.
This commit is contained in:
Mark H Weaver
parent
87f32999b9
commit
de42f12099
7 changed files with 56 additions and 33 deletions
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue