[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Add support for optimized unboxed abs and sqrt
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/01: Add support for optimized unboxed abs and sqrt |
|
Date: |
Sun, 4 Aug 2019 15:55:07 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit 382cc5c246ccbe8dc1f6fa589f4fcf7f076fab69
Author: Andy Wingo <address@hidden>
Date: Sun Aug 4 21:45:25 2019 +0200
Add support for optimized unboxed abs and sqrt
Some components of this have been wired up for a while; this commit
finishes the compiler, runtime, and JIT support.
* libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS):
* libguile/intrinsics.c (scm_bootstrap_intrinsics): Declare the new
intrinsics.
* libguile/jit.c (compile_call_f64_from_f64): Define code generators for
the new intrinsics.
* libguile/vm-engine.c (call-f64<-f64): New instruction.
* module/language/cps/effects-analysis.scm:
* module/language/cps/reify-primitives.scm (compute-known-primitives):
* module/language/cps/slot-allocation.scm (compute-var-representations):
* module/language/cps/specialize-numbers.scm (specialize-operations):
* module/language/tree-il/cps-primitives.scm (abs):
* module/system/vm/assembler.scm (system, define-f64<-f64-intrinsic):
(sqrt, abs, fsqrt, fabs):
* module/language/cps/types.scm (fsqrt, fabs): Add new f64<-f64
primitives.
---
libguile/intrinsics.c | 6 ++++++
libguile/intrinsics.h | 5 +++++
libguile/jit.c | 26 ++++++++++++++++++++++++++
libguile/vm-engine.c | 20 +++++++++++++++++++-
module/language/cps/effects-analysis.scm | 6 ++++--
module/language/cps/reify-primitives.scm | 4 ++++
module/language/cps/slot-allocation.scm | 2 +-
module/language/cps/specialize-numbers.scm | 6 ++++++
module/language/cps/types.scm | 16 ++++++++++++++++
module/language/tree-il/cps-primitives.scm | 4 +++-
module/system/vm/assembler.scm | 11 +++++++++++
11 files changed, 101 insertions(+), 5 deletions(-)
diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index ced3711..a00ab39 100644
--- a/libguile/intrinsics.c
+++ b/libguile/intrinsics.c
@@ -21,6 +21,8 @@
# include <config.h>
#endif
+#include <math.h>
+
#include "alist.h"
#include "atomics-internal.h"
#include "boolean.h"
@@ -516,6 +518,10 @@ scm_bootstrap_intrinsics (void)
scm_vm_intrinsics.current_module = current_module;
scm_vm_intrinsics.push_prompt = push_prompt;
scm_vm_intrinsics.allocate_words_with_freelist =
allocate_words_with_freelist;
+ scm_vm_intrinsics.abs = scm_abs;
+ scm_vm_intrinsics.sqrt = scm_sqrt;
+ scm_vm_intrinsics.fabs = fabs;
+ scm_vm_intrinsics.fsqrt = sqrt;
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_intrinsics",
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index de4f0e2..15add95 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -92,6 +92,7 @@ typedef SCM (*scm_t_scm_from_ptr_intrinsic) (SCM*);
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 uint32_t* scm_t_vcode_intrinsic;
#define SCM_FOR_ALL_VM_INTRINSICS(M) \
@@ -162,6 +163,10 @@ typedef uint32_t* scm_t_vcode_intrinsic;
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_thread_sz, allocate_words_with_freelist,
"allocate-words/freelist", ALLOCATE_WORDS_WITH_FREELIST) \
+ M(scm_from_scm, abs, "abs", ABS) \
+ M(scm_from_scm, sqrt, "sqrt", SQRT) \
+ M(f64_from_f64, fabs, "fabs", FABS) \
+ M(f64_from_f64, fsqrt, "fsqrt", FSQRT) \
/* Add new intrinsics here; also update scm_bootstrap_intrinsics. */
enum scm_vm_intrinsic
diff --git a/libguile/jit.c b/libguile/jit.c
index 082eb3e..a8b2270 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -516,6 +516,8 @@ DEFINE_CLOBBER_RECORDING_EMITTER_R_I(muli, gpr)
DEFINE_CLOBBER_RECORDING_EMITTER_R_R(mulr, gpr)
DEFINE_CLOBBER_RECORDING_EMITTER_R_R(mulr_d, fpr)
DEFINE_CLOBBER_RECORDING_EMITTER_R_R(divr_d, fpr)
+DEFINE_CLOBBER_RECORDING_EMITTER_R(absr_d, fpr)
+DEFINE_CLOBBER_RECORDING_EMITTER_R(sqrtr_d, fpr)
DEFINE_CLOBBER_RECORDING_EMITTER_R_I(andi, gpr)
DEFINE_CLOBBER_RECORDING_EMITTER_R_R(andr, gpr)
DEFINE_CLOBBER_RECORDING_EMITTER_R_R(orr, gpr)
@@ -2363,6 +2365,30 @@ compile_call_f64_from_scm (scm_jit_state *j, uint16_t
dst, uint16_t a, uint32_t
}
static void
+compile_call_f64_from_f64 (scm_jit_state *j, uint16_t dst, uint16_t src,
uint32_t idx)
+{
+ switch ((enum scm_vm_intrinsic) idx)
+ {
+ case SCM_VM_INTRINSIC_FABS:
+ {
+ emit_sp_ref_f64 (j, JIT_F0, src);
+ emit_absr_d (j, JIT_F0, JIT_F0);
+ emit_sp_set_f64 (j, dst, JIT_F0);
+ break;
+ }
+ case SCM_VM_INTRINSIC_FSQRT:
+ {
+ emit_sp_ref_f64 (j, JIT_F0, src);
+ emit_sqrtr_d (j, JIT_F0, JIT_F0);
+ emit_sp_set_f64 (j, dst, JIT_F0);
+ break;
+ }
+ default:
+ DIE("unhandled f64<-f64");
+ }
+}
+
+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 469a31c..ab34d42 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3242,7 +3242,25 @@ VM_NAME (scm_thread *thread)
NEXT (1);
}
- VM_DEFINE_OP (155, unused_155, NULL, NOP)
+ /* call-f64<-f64 dst:12 src:12 IDX:32
+ *
+ * Call the double-returning instrinsic with index IDX, passing SCM
+ * local SRC as argument. Place the double result in DST.
+ */
+ VM_DEFINE_OP (155, call_f64_from_f64, "call-f64<-f64", DOP2 (X8_S12_S12,
C32))
+ {
+ uint16_t dst, src;
+ scm_t_f64_from_f64_intrinsic intrinsic;
+
+ UNPACK_12_12 (op, dst, src);
+ intrinsic = intrinsics[ip[1]];
+
+ /* We assume these instructions can't throw an exception. */
+ SP_SET_F64 (dst, intrinsic (SP_REF_F64 (src)));
+
+ NEXT (2);
+ }
+
VM_DEFINE_OP (156, unused_156, NULL, NOP)
VM_DEFINE_OP (157, unused_157, NULL, NOP)
VM_DEFINE_OP (158, unused_158, NULL, NOP)
diff --git a/module/language/cps/effects-analysis.scm
b/module/language/cps/effects-analysis.scm
index 250aec7..f35a56a 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -1,6 +1,6 @@
;;; Effects analysis on CPS
-;; Copyright (C) 2011-2015, 2017, 2018 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2015,2017-2019 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -549,7 +549,9 @@ the LABELS that are clobbered by the effects of LABEL."
((logtest a b) &type-check)
((logbit? a b) &type-check)
((sqrt _) &type-check)
- ((abs _) &type-check))
+ ((abs _) &type-check)
+ ((fsqrt _))
+ ((fabs _)))
;; Characters.
(define-primitive-effects
diff --git a/module/language/cps/reify-primitives.scm
b/module/language/cps/reify-primitives.scm
index 6ec9029..2f8cb52 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -314,6 +314,10 @@
quo
rem
mod
+ sqrt
+ abs
+ fsqrt
+ fabs
logand
logior
logxor
diff --git a/module/language/cps/slot-allocation.scm
b/module/language/cps/slot-allocation.scm
index 247d648..91ce0df 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -756,7 +756,7 @@ are comparable with eqv?. A tmp slot may be used."
(intmap-ref representations arg)))
(($ $primcall (or 'scm->f64 'load-f64
'f32-ref 'f64-ref
- 'fadd 'fsub 'fmul 'fdiv))
+ 'fadd 'fsub 'fmul 'fdiv 'fsqrt 'fabs))
(intmap-add representations var 'f64))
(($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
's64->u64
diff --git a/module/language/cps/specialize-numbers.scm
b/module/language/cps/specialize-numbers.scm
index dc8e26f..a0fafb2 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -452,6 +452,12 @@ BITS indicating the significant bits needed for a
variable. BITS may be
(specialize-binop cps k src op a b
(unbox-f64 a) (unbox-f64 b) (box-f64 result))))
+ (((or 'sqrt 'abs)
+ (? f64-result?) #f a)
+ (let ((op (match op ('sqrt 'fsqrt) ('abs 'fabs))))
+ (specialize-unop cps k src op #f a
+ (unbox-f64 a) (box-f64 result))))
+
(((or 'add 'sub 'mul 'logand 'logior 'logxor 'logsub)
(? u64-result?) #f (? u64-operand? a) (? u64-operand? b))
(let ((op (match op
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index bcf22d3..f6db09f 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1680,6 +1680,16 @@ where (A0 <= A <= A1) and (B0 <= B <= B1)."
(if (zero? r) s (+ s 1)))))))
(else
(define! result (logior type &flonum &complex) -inf.0 +inf.0)))))
+(define-type-checker (fsqrt x) #t)
+(define-type-inferrer (fsqrt x result)
+ (define! result
+ &f64
+ (exact-integer-sqrt (max (&min x) 0))
+ (if (inf? (&max x))
+ +inf.0
+ (call-with-values (lambda () (exact-integer-sqrt (&max x)))
+ (lambda (s r)
+ (if (zero? r) s (+ s 1)))))))
(define-simple-type-checker (abs &real))
(define-type-inferrer (abs x result)
@@ -1704,6 +1714,12 @@ where (A0 <= A <= A1) and (B0 <= B <= B1)."
(define! result (logior (logand type (lognot &number))
(logand type &real))
min max))))))
+(define-type-checker (fabs x) #t)
+(define-type-inferrer (fabs x result)
+ (let ((min (if (< (&min x) 0) 0 (&min x)))
+ (max (max (abs (&min x)) (abs (&max x)))))
+ (define! result &f64 min max)))
+
diff --git a/module/language/tree-il/cps-primitives.scm
b/module/language/tree-il/cps-primitives.scm
index b9f2fe9..17afa0d 100644
--- a/module/language/tree-il/cps-primitives.scm
+++ b/module/language/tree-il/cps-primitives.scm
@@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL)
-;; Copyright (C) 2013- 2015, 2017-2018 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2015, 2017-2019 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -85,6 +85,8 @@
(define-cps-primitive (quotient quo) 2 1)
(define-cps-primitive (remainder rem) 2 1)
(define-cps-primitive (modulo mod) 2 1)
+(define-cps-primitive sqrt 1 1)
+(define-cps-primitive abs 1 1)
(define-cps-primitive lsh 2 1)
(define-cps-primitive rsh 2 1)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index c9e9f5f..d8a84dd 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -197,6 +197,10 @@
emit-quo
emit-rem
emit-mod
+ emit-abs
+ emit-sqrt
+ emit-fabs
+ emit-fsqrt
emit-logand
emit-logior
emit-logxor
@@ -1321,6 +1325,9 @@ 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-f64<-f64-intrinsic name)
+ (define-macro-assembler (name asm dst src)
+ (emit-call-f64<-f64 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))))
@@ -1364,6 +1371,10 @@ returned instead."
(define-scm<-scm-scm-intrinsic quo)
(define-scm<-scm-scm-intrinsic rem)
(define-scm<-scm-scm-intrinsic mod)
+(define-scm<-scm-intrinsic abs)
+(define-scm<-scm-intrinsic sqrt)
+(define-f64<-f64-intrinsic fabs)
+(define-f64<-f64-intrinsic fsqrt)
(define-scm<-scm-scm-intrinsic logand)
(define-scm<-scm-scm-intrinsic logior)
(define-scm<-scm-scm-intrinsic logxor)