mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-01 04:10:18 +02:00
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.
This commit is contained in:
Andy Wingo
parent
9e3a5c9a10
commit
b1564df298
12 changed files with 278 additions and 10 deletions
|
|
@ -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",
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,8 +2392,25 @@ 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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -550,8 +550,26 @@ the LABELS that are clobbered by the effects of LABEL."
|
|||
((logbit? a b) &type-check)
|
||||
((sqrt _) &type-check)
|
||||
((abs _) &type-check)
|
||||
((floor _) &type-check)
|
||||
((ceiling _) &type-check)
|
||||
((sin _) &type-check)
|
||||
((cos _) &type-check)
|
||||
((tan _) &type-check)
|
||||
((asin _) &type-check)
|
||||
((acos _) &type-check)
|
||||
((atan _) &type-check)
|
||||
((atan2 x y) &type-check)
|
||||
((fsqrt _))
|
||||
((fabs _)))
|
||||
((fabs _))
|
||||
((ffloor _))
|
||||
((fceiling _))
|
||||
((fsin _))
|
||||
((fcos _))
|
||||
((ftan _))
|
||||
((fasin _))
|
||||
((facos _))
|
||||
((fatan _))
|
||||
((fatan2 x y)))
|
||||
|
||||
;; Characters.
|
||||
(define-primitive-effects
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Continuation-passing style (CPS) intermediate language (IL)
|
||||
|
||||
;; Copyright (C) 2013, 2014, 2015, 2017, 2018 Free Software Foundation, Inc.
|
||||
;; Copyright (C) 2013-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
|
||||
|
|
@ -316,8 +316,26 @@
|
|||
mod
|
||||
sqrt
|
||||
abs
|
||||
floor
|
||||
ceiling
|
||||
sin
|
||||
cos
|
||||
tan
|
||||
asin
|
||||
acos
|
||||
atan
|
||||
atan2
|
||||
fsqrt
|
||||
fabs
|
||||
ffloor
|
||||
fceiling
|
||||
fsin
|
||||
fcos
|
||||
ftan
|
||||
fasin
|
||||
facos
|
||||
fatan
|
||||
fatan2
|
||||
logand
|
||||
logior
|
||||
logxor
|
||||
|
|
|
|||
|
|
@ -756,7 +756,9 @@ 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 'fsqrt 'fabs))
|
||||
'fadd 'fsub 'fmul 'fdiv 'fsqrt 'fabs
|
||||
'ffloor 'fceiling
|
||||
'fsin 'fcos 'ftan 'fasin 'facos 'fatan 'fatan2))
|
||||
(intmap-add representations var 'f64))
|
||||
(($ $primcall (or 'scm->u64 'scm->u64/truncate 'load-u64
|
||||
's64->u64
|
||||
|
|
|
|||
|
|
@ -445,16 +445,21 @@ BITS indicating the significant bits needed for a variable. BITS may be
|
|||
(match (intmap-ref cps k)
|
||||
(($ $kargs (_) (result))
|
||||
(match (cons* op result param args)
|
||||
(((or 'add 'sub 'mul 'div)
|
||||
(((or 'add 'sub 'mul 'div 'atan2)
|
||||
(? f64-result?) #f a b)
|
||||
(let ((op (match op
|
||||
('add 'fadd) ('sub 'fsub) ('mul 'fmul) ('div 'fdiv))))
|
||||
('add 'fadd) ('sub 'fsub) ('mul 'fmul) ('div 'fdiv)
|
||||
('atan2 'fatan2))))
|
||||
(specialize-binop cps k src op a b
|
||||
(unbox-f64 a) (unbox-f64 b) (box-f64 result))))
|
||||
|
||||
(((or 'sqrt 'abs)
|
||||
(((or 'sqrt 'abs 'floor 'ceiling 'sin 'cos 'tan 'asin 'acos 'atan)
|
||||
(? f64-result?) #f a)
|
||||
(let ((op (match op ('sqrt 'fsqrt) ('abs 'fabs))))
|
||||
(let ((op (match op
|
||||
('sqrt 'fsqrt) ('abs 'fabs)
|
||||
('floor 'ffloor) ('ceiling 'fceiling)
|
||||
('sin 'fsin) ('cos 'fcos) ('tan 'ftan)
|
||||
('asin 'fasin) ('acos 'facos) ('atan 'fatan))))
|
||||
(specialize-unop cps k src op #f a
|
||||
(unbox-f64 a) (box-f64 result))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1720,6 +1720,92 @@ where (A0 <= A <= A1) and (B0 <= B <= B1)."
|
|||
(max (max (abs (&min x)) (abs (&max x)))))
|
||||
(define! result &f64 min max)))
|
||||
|
||||
(define-simple-type-checker (floor &real))
|
||||
(define-type-inferrer (floor x result)
|
||||
(restrict! x &real -inf.0 +inf.0)
|
||||
(let* ((in (logand (&type x) &real))
|
||||
(out (cond
|
||||
((type<=? in &flonum) &flonum)
|
||||
((type<=? in &exact-integer) in)
|
||||
((logtest in &fraction)
|
||||
(logior (logand in (lognot &fraction)) &exact-integer)))))
|
||||
(define! result out (&min x) (&max x))))
|
||||
(define-type-checker (ffloor x) #t)
|
||||
(define-type-inferrer (ffloor x result)
|
||||
(define! result &f64 (&min x) (&max x)))
|
||||
|
||||
(define-type-aliases floor ceiling)
|
||||
(define-type-aliases ffloor fceiling)
|
||||
|
||||
(define-simple-type-checker (sin &number))
|
||||
(define-type-inferrer (sin x result)
|
||||
(let* ((in (&type x))
|
||||
(out (cond
|
||||
((type<=? in &real) &flonum)
|
||||
((type<=? in &complex) &complex)
|
||||
(else (logior &flonum &complex (logand in (lognot &number)))))))
|
||||
(define! result out -1 1)))
|
||||
(define-type-checker (fsin x) #t)
|
||||
(define-type-inferrer (fsin x result)
|
||||
(define! result &f64 -1 1))
|
||||
|
||||
(define-type-aliases sin cos)
|
||||
(define-type-aliases fsin fcos)
|
||||
|
||||
(define-simple-type-checker (tan &number))
|
||||
(define-type-inferrer (tan x result)
|
||||
(let* ((in (&type x))
|
||||
(out (cond
|
||||
((type<=? in &real) &flonum)
|
||||
((type<=? in &complex) &complex)
|
||||
(else (logior &flonum &complex (logand in (lognot &number)))))))
|
||||
(define! result out -inf.0 +inf.0)))
|
||||
(define-type-checker (ftan x) #t)
|
||||
(define-type-inferrer (ftan x result)
|
||||
(define! result &f64 -inf.0 +inf.0))
|
||||
|
||||
(define-simple-type-checker (asin &number))
|
||||
(define-type-inferrer (asin x result)
|
||||
(define! result
|
||||
(logior &flonum &complex (logand (&type x) (lognot &number)))
|
||||
-inf.0 +inf.0))
|
||||
(define-type-checker (fasin x) #t)
|
||||
(define-type-inferrer (fasin x result)
|
||||
(define! result &f64 -2 2)) ; [-pi/2, pi/2]
|
||||
|
||||
(define-type-aliases asin acos)
|
||||
(define-type-checker (facos x) #t)
|
||||
(define-type-inferrer (facos x result)
|
||||
(define! result &f64 0 4)) ; [0, pi]
|
||||
|
||||
(define-simple-type-checker (atan &number))
|
||||
(define-type-inferrer (atan x result)
|
||||
(let ((in (&type x)))
|
||||
(cond
|
||||
((type<=? in &real)
|
||||
(define! result &flonum -2 2)) ; [-pi/2, pi/2]
|
||||
(else
|
||||
(define! result
|
||||
(logior &flonum &complex (logand in (lognot &number)))
|
||||
-inf.0 +inf.0)))))
|
||||
(define-type-checker (fatan x) #t)
|
||||
(define-type-inferrer (fatan x result)
|
||||
(define! result &f64 -2 2))
|
||||
|
||||
(define-simple-type-checker (atan2 &number &number))
|
||||
(define-type-inferrer (atan2 x y result)
|
||||
(let* ((in (logior (&type x) (&type y))))
|
||||
(cond
|
||||
((type<=? in &real)
|
||||
(define! result &flonum -4 4)) ; [-pi, pi]
|
||||
(else
|
||||
(define! result (logior &flonum &complex (logand in (lognot &number)))
|
||||
-inf.0 +inf.0)))))
|
||||
(define-type-checker (fatan2 x y) #t)
|
||||
(define-type-inferrer (fatan2 x y result)
|
||||
(define! result &f64 -4 4))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -89,6 +89,15 @@
|
|||
(define-cps-primitive (modulo mod) 2 1)
|
||||
(define-cps-primitive sqrt 1 1)
|
||||
(define-cps-primitive abs 1 1)
|
||||
(define-cps-primitive floor 1 1)
|
||||
(define-cps-primitive ceiling 1 1)
|
||||
(define-cps-primitive sin 1 1)
|
||||
(define-cps-primitive cos 1 1)
|
||||
(define-cps-primitive tan 1 1)
|
||||
(define-cps-primitive asin 1 1)
|
||||
(define-cps-primitive acos 1 1)
|
||||
(define-cps-primitive atan 1 1)
|
||||
(define-cps-primitive atan2 2 1)
|
||||
|
||||
(define-cps-primitive lsh 2 1)
|
||||
(define-cps-primitive rsh 2 1)
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@
|
|||
= < > <= >= zero? positive? negative?
|
||||
+ * - / 1- 1+ quotient remainder modulo
|
||||
ash logand logior logxor lognot logtest logbit?
|
||||
sqrt abs
|
||||
sqrt abs floor ceiling sin cos tan asin acos atan
|
||||
not
|
||||
pair? null? list? symbol? vector? string? struct? number? char? nil?
|
||||
bytevector? keyword? bitvector?
|
||||
|
|
@ -172,6 +172,7 @@
|
|||
= < > <= >= zero? positive? negative?
|
||||
ash logand logior logxor lognot logtest logbit?
|
||||
+ * - / 1- 1+ sqrt abs quotient remainder modulo
|
||||
floor ceiling sin cos tan asin acos atan
|
||||
not
|
||||
pair? null? nil? list?
|
||||
symbol? variable? vector? struct? string? number? char?
|
||||
|
|
@ -441,6 +442,10 @@
|
|||
(x) (/ 1 x)
|
||||
(x y z ... last) (/ (/ x y . z) last))
|
||||
|
||||
(define-primitive-expander atan
|
||||
(x) (atan x)
|
||||
(x y) (atan2 x y))
|
||||
|
||||
(define-primitive-expander logior
|
||||
() 0
|
||||
(x) (logior x 0)
|
||||
|
|
|
|||
|
|
@ -199,8 +199,26 @@
|
|||
emit-mod
|
||||
emit-abs
|
||||
emit-sqrt
|
||||
emit-floor
|
||||
emit-ceiling
|
||||
emit-sin
|
||||
emit-cos
|
||||
emit-tan
|
||||
emit-asin
|
||||
emit-acos
|
||||
emit-atan
|
||||
emit-atan2
|
||||
emit-fabs
|
||||
emit-fsqrt
|
||||
emit-ffloor
|
||||
emit-fceiling
|
||||
emit-fsin
|
||||
emit-fcos
|
||||
emit-ftan
|
||||
emit-fasin
|
||||
emit-facos
|
||||
emit-fatan
|
||||
emit-fatan2
|
||||
emit-logand
|
||||
emit-logior
|
||||
emit-logxor
|
||||
|
|
@ -1339,6 +1357,9 @@ returned instead."
|
|||
(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-f64<-f64-f64-intrinsic name)
|
||||
(define-macro-assembler (name asm dst a b)
|
||||
(emit-call-f64<-f64-f64 asm dst a b (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))))
|
||||
|
|
@ -1384,8 +1405,26 @@ returned instead."
|
|||
(define-scm<-scm-scm-intrinsic mod)
|
||||
(define-scm<-scm-intrinsic abs)
|
||||
(define-scm<-scm-intrinsic sqrt)
|
||||
(define-scm<-scm-intrinsic floor)
|
||||
(define-scm<-scm-intrinsic ceiling)
|
||||
(define-scm<-scm-intrinsic sin)
|
||||
(define-scm<-scm-intrinsic cos)
|
||||
(define-scm<-scm-intrinsic tan)
|
||||
(define-scm<-scm-intrinsic asin)
|
||||
(define-scm<-scm-intrinsic acos)
|
||||
(define-scm<-scm-intrinsic atan)
|
||||
(define-scm<-scm-scm-intrinsic atan2)
|
||||
(define-f64<-f64-intrinsic fabs)
|
||||
(define-f64<-f64-intrinsic fsqrt)
|
||||
(define-f64<-f64-intrinsic ffloor)
|
||||
(define-f64<-f64-intrinsic fceiling)
|
||||
(define-f64<-f64-intrinsic fsin)
|
||||
(define-f64<-f64-intrinsic fcos)
|
||||
(define-f64<-f64-intrinsic ftan)
|
||||
(define-f64<-f64-intrinsic fasin)
|
||||
(define-f64<-f64-intrinsic facos)
|
||||
(define-f64<-f64-intrinsic fatan)
|
||||
(define-f64<-f64-f64-intrinsic fatan2)
|
||||
(define-scm<-scm-scm-intrinsic logand)
|
||||
(define-scm<-scm-scm-intrinsic logior)
|
||||
(define-scm<-scm-scm-intrinsic logxor)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue