summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2019-08-24 11:37:17 +0200
committerAndy Wingo <wingo@pobox.com>2019-08-24 11:56:18 +0200
commitb1564df298dbdd261e880837c89f04d3d82879ea (patch)
treea614f15de77aef414b45d53f824fcc414f2cd8bd /libguile
parent9e3a5c9a10d4202dabab0c93fb75d7e07201bb24 (diff)
downloadguile-b1564df298dbdd261e880837c89f04d3d82879ea.tar.gz
Unbox floor/ceiling and trigonometric functions where possible
* libguile/intrinsics.c (scm_atan1): New intrinsic, wrapping scm_atan. (scm_bootstrap_intrinsics): Add new intrinsics. * libguile/intrinsics.h (scm_t_f64_from_f64_f64_intrinsic): New intrinsic type. (SCM_FOR_ALL_VM_INTRINSICS): Add intrinsics for floor, ceiling, sin, cos, tan, asin, acos, atan, and their unboxed counterparts. * libguile/jit.c (sp_f64_operand): New helper. (compile_call_f64_from_f64, compile_call_f64_from_f64_f64): Call out to intrinsics. * libguile/vm-engine.c (call-f64<-f64-f64): New opcode. * module/language/cps/effects-analysis.scm: Add new intrinsics. * module/language/cps/reify-primitives.scm (compute-known-primitives): Add new intrinsics. * module/language/cps/slot-allocation.scm (compute-var-representations): Add 'f64 slot types for the new unboxed intrinsics. * module/language/cps/specialize-numbers.scm (specialize-operations): Support unboxing the new intrinsics. * module/language/cps/types.scm: Define type inferrers for the new intrinsics. * module/language/tree-il/cps-primitives.scm: Define CPS translations for the new intrinsics. * module/language/tree-il/primitives.scm (*interesting-primitive-names*): (*effect-free-primitives*, atan): Define primitive resolvers. * module/system/vm/assembler.scm: Export assemblers for the new intrinsics. (define-f64<-f64-f64-intrinsic): New helper.
Diffstat (limited to 'libguile')
-rw-r--r--libguile/intrinsics.c24
-rw-r--r--libguile/intrinsics.h19
-rw-r--r--libguile/jit.c27
-rw-r--r--libguile/vm-engine.c20
4 files changed, 88 insertions, 2 deletions
diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index a00ab39f6..3a91d0753 100644
--- a/libguile/intrinsics.c
+++ b/libguile/intrinsics.c
@@ -449,6 +449,12 @@ push_prompt (scm_thread *thread, uint8_t escape_only_p,
vra, mra, thread->vm.registers);
}
+static SCM
+scm_atan1 (SCM x)
+{
+ return scm_atan (x, SCM_UNDEFINED);
+}
+
void
scm_bootstrap_intrinsics (void)
{
@@ -522,6 +528,24 @@ scm_bootstrap_intrinsics (void)
scm_vm_intrinsics.sqrt = scm_sqrt;
scm_vm_intrinsics.fabs = fabs;
scm_vm_intrinsics.fsqrt = sqrt;
+ scm_vm_intrinsics.floor = scm_floor;
+ scm_vm_intrinsics.ceiling = scm_ceiling;
+ scm_vm_intrinsics.sin = scm_sin;
+ scm_vm_intrinsics.cos = scm_cos;
+ scm_vm_intrinsics.tan = scm_tan;
+ scm_vm_intrinsics.asin = scm_asin;
+ scm_vm_intrinsics.acos = scm_acos;
+ scm_vm_intrinsics.atan = scm_atan1;
+ scm_vm_intrinsics.atan2 = scm_atan;
+ scm_vm_intrinsics.ffloor = floor;
+ scm_vm_intrinsics.fceiling = ceil;
+ scm_vm_intrinsics.fsin = sin;
+ scm_vm_intrinsics.fcos = cos;
+ scm_vm_intrinsics.ftan = tan;
+ scm_vm_intrinsics.fasin = asin;
+ scm_vm_intrinsics.facos = acos;
+ scm_vm_intrinsics.fatan = atan;
+ scm_vm_intrinsics.fatan = atan2;
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_intrinsics",
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index 15add953f..eed871234 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -93,6 +93,7 @@ typedef void (*scm_t_ptr_scm_intrinsic) (SCM*, SCM);
typedef SCM (*scm_t_scm_from_ptr_scm_intrinsic) (SCM*, SCM);
typedef SCM (*scm_t_scm_from_ptr_scm_scm_intrinsic) (SCM*, SCM, SCM);
typedef double (*scm_t_f64_from_f64_intrinsic) (double);
+typedef double (*scm_t_f64_from_f64_f64_intrinsic) (double, double);
typedef uint32_t* scm_t_vcode_intrinsic;
#define SCM_FOR_ALL_VM_INTRINSICS(M) \
@@ -167,6 +168,24 @@ typedef uint32_t* scm_t_vcode_intrinsic;
M(scm_from_scm, sqrt, "sqrt", SQRT) \
M(f64_from_f64, fabs, "fabs", FABS) \
M(f64_from_f64, fsqrt, "fsqrt", FSQRT) \
+ M(scm_from_scm, floor, "floor", FLOOR) \
+ M(scm_from_scm, ceiling, "ceiling", CEILING) \
+ M(scm_from_scm, sin, "sin", SIN) \
+ M(scm_from_scm, cos, "cos", COS) \
+ M(scm_from_scm, tan, "tan", TAN) \
+ M(scm_from_scm, asin, "asin", ASIN) \
+ M(scm_from_scm, acos, "acos", ACOS) \
+ M(scm_from_scm, atan, "atan", ATAN) \
+ M(scm_from_scm_scm, atan2, "atan2", ATAN2) \
+ M(f64_from_f64, ffloor, "ffloor", FFLOOR) \
+ M(f64_from_f64, fceiling, "fceiling", FCEILING) \
+ M(f64_from_f64, fsin, "fsin", FSIN) \
+ M(f64_from_f64, fcos, "fcos", FCOS) \
+ M(f64_from_f64, ftan, "ftan", FTAN) \
+ M(f64_from_f64, fasin, "fasin", FASIN) \
+ M(f64_from_f64, facos, "facos", FACOS) \
+ M(f64_from_f64, fatan, "fatan", FATAN) \
+ M(f64_from_f64_f64, fatan2, "fatan2", FATAN2) \
/* Add new intrinsics here; also update scm_bootstrap_intrinsics. */
enum scm_vm_intrinsic
diff --git a/libguile/jit.c b/libguile/jit.c
index a8b2270a2..136b8bcaf 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -1098,6 +1098,14 @@ emit_sp_ref_ptr (scm_jit_state *j, jit_gpr_t dst, uint32_t src)
}
#endif /* SCM_SIZEOF_UINTPTR_T >= 8 */
+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 void
emit_sp_ref_f64 (scm_jit_state *j, jit_fpr_t dst, uint32_t src)
{
@@ -2384,11 +2392,28 @@ compile_call_f64_from_f64 (scm_jit_state *j, uint16_t dst, uint16_t src, uint32_
break;
}
default:
- DIE("unhandled f64<-f64");
+ {
+ void *intrinsic = ((void **) &scm_vm_intrinsics)[idx];
+ emit_call_1 (j, intrinsic, sp_f64_operand (j, src));
+ emit_retval_d (j, JIT_F0);
+ emit_reload_sp (j);
+ emit_sp_set_f64 (j, dst, JIT_F0);
+ break;
+ }
}
}
static void
+compile_call_f64_from_f64_f64 (scm_jit_state *j, uint8_t dst, uint8_t a, uint8_t b, uint32_t idx)
+{
+ void *intrinsic = ((void **) &scm_vm_intrinsics)[idx];
+ emit_call_2 (j, intrinsic, sp_f64_operand (j, a), sp_f64_operand (j, b));
+ emit_retval_d (j, JIT_F0);
+ emit_reload_sp (j);
+ emit_sp_set_f64 (j, dst, JIT_F0);
+}
+
+static void
compile_call_u64_from_scm (scm_jit_state *j, uint16_t dst, uint16_t a, uint32_t idx)
{
void *intrinsic = ((void **) &scm_vm_intrinsics)[idx];
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index ab34d42b9..0c2c8e7bf 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3261,7 +3261,25 @@ VM_NAME (scm_thread *thread)
NEXT (2);
}
- VM_DEFINE_OP (156, unused_156, NULL, NOP)
+ /* call-f64<-f64-f64 dst:8 a:8 b:8 IDX:32
+ *
+ * Call the double-returning instrinsic with index IDX, passing SCM
+ * locals A and B as arguments. Place the double result in DST.
+ */
+ VM_DEFINE_OP (156, call_f64_from_f64_f64, "call-f64<-f64-f64", DOP2 (X8_S8_S8_S8, C32))
+ {
+ uint8_t dst, a, b;
+ scm_t_f64_from_f64_f64_intrinsic intrinsic;
+
+ UNPACK_8_8_8 (op, dst, a, b);
+ intrinsic = intrinsics[ip[1]];
+
+ /* We assume these instructions can't throw an exception. */
+ SP_SET_F64 (dst, intrinsic (SP_REF_F64 (a), SP_REF_F64 (b)));
+
+ NEXT (2);
+ }
+
VM_DEFINE_OP (157, unused_157, NULL, NOP)
VM_DEFINE_OP (158, unused_158, NULL, NOP)
VM_DEFINE_OP (159, unused_159, NULL, NOP)