From b1564df298dbdd261e880837c89f04d3d82879ea Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 24 Aug 2019 11:37:17 +0200 Subject: [PATCH] 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. --- libguile/intrinsics.c | 24 ++++++ libguile/intrinsics.h | 19 +++++ libguile/jit.c | 27 ++++++- libguile/vm-engine.c | 20 ++++- module/language/cps/effects-analysis.scm | 20 ++++- module/language/cps/reify-primitives.scm | 20 ++++- module/language/cps/slot-allocation.scm | 4 +- module/language/cps/specialize-numbers.scm | 13 +++- module/language/cps/types.scm | 86 ++++++++++++++++++++++ module/language/tree-il/cps-primitives.scm | 9 +++ module/language/tree-il/primitives.scm | 7 +- module/system/vm/assembler.scm | 39 ++++++++++ 12 files changed, 278 insertions(+), 10 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,10 +2392,27 @@ 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) { 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) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index f35a56a04..f5d6bb534 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -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 diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm index 2f8cb5245..547ea59ee 100644 --- a/module/language/cps/reify-primitives.scm +++ b/module/language/cps/reify-primitives.scm @@ -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 diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 91ce0dfe3..497df7a23 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -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 diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm index a0fafb215..2ef44050d 100644 --- a/module/language/cps/specialize-numbers.scm +++ b/module/language/cps/specialize-numbers.scm @@ -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)))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index f6db09fb4..cf2fe912a 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -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)) + + diff --git a/module/language/tree-il/cps-primitives.scm b/module/language/tree-il/cps-primitives.scm index beb29b99e..e5c2544ee 100644 --- a/module/language/tree-il/cps-primitives.scm +++ b/module/language/tree-il/cps-primitives.scm @@ -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) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index b7bd4fb8f..cb1145ebd 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -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) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index ab234525e..cb4311093 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -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)