[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 05/07: DRAFT: Change f64->scm into an intrinsic.
From: |
Mark H. Weaver |
Subject: |
[Guile-commits] 05/07: DRAFT: Change f64->scm into an intrinsic. |
Date: |
Thu, 6 Jun 2019 05:37:14 -0400 (EDT) |
mhw pushed a commit to branch wip-new-tagging
in repository guile.
commit de42f120999d3ca745ecec347ca8dfda7f12c181
Author: Mark H Weaver <address@hidden>
Date: Wed Jun 5 22:23:46 2019 -0400
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 ab6b6a8..d527e04 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 2c1b53a..306d269 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 82c6252..95ff7fc 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -983,6 +983,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)
{
ASSERT_HAS_REGISTER_STATE (SP_IN_REGISTER);
@@ -2436,6 +2444,18 @@ compile_call_s64_from_scm (scm_jit_state *j, uint16_t
dst, uint16_t a, uint32_t
}
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)
{
void *intrinsic = ((void **) &scm_vm_intrinsics)[idx];
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index f2dcc91..fd8a604 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 15c0ade..fdf898d 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 6ec9029..9305fb4 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
@@ -369,37 +369,6 @@
(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
(setk label ($kargs names vars
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index cfda4f9..a45ded8 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)
- [Guile-commits] branch wip-new-tagging created (now f08e08b), Mark H. Weaver, 2019/06/06
- [Guile-commits] 01/07: fix typo, Mark H. Weaver, 2019/06/06
- [Guile-commits] 05/07: DRAFT: Change f64->scm into an intrinsic.,
Mark H. Weaver <=
- [Guile-commits] 07/07: DRAFT: Add immediate fractions (fixrats)., Mark H. Weaver, 2019/06/06
- [Guile-commits] 03/07: DRAFT: Use 'eqv?' instead of 'eq?' in intmap.scm, intset.scm, etc., Mark H. Weaver, 2019/06/06
- [Guile-commits] 06/07: DRAFT: Add immediate floats (iflos)., Mark H. Weaver, 2019/06/06
- [Guile-commits] 02/07: DRAFT: Scheme eval: Add source annotations to generated procedures., Mark H. Weaver, 2019/06/06
- [Guile-commits] 04/07: WIP: New tagging v8, Mark H. Weaver, 2019/06/06