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.

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

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

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

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))))
 

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))
+
+
 
 
 

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)

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)