summaryrefslogtreecommitdiff
path: root/module
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 /module
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 'module')
-rw-r--r--module/language/cps/effects-analysis.scm20
-rw-r--r--module/language/cps/reify-primitives.scm20
-rw-r--r--module/language/cps/slot-allocation.scm4
-rw-r--r--module/language/cps/specialize-numbers.scm13
-rw-r--r--module/language/cps/types.scm86
-rw-r--r--module/language/tree-il/cps-primitives.scm9
-rw-r--r--module/language/tree-il/primitives.scm7
-rw-r--r--module/system/vm/assembler.scm39
8 files changed, 190 insertions, 8 deletions
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)