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.

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

module/language/cps/reify-primitives.scm

@@ -314,6 +314,10 @@
       quo
       rem
       mod
+      sqrt
+      abs
+      fsqrt
+      fabs
       logand
       logior
       logxor

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

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

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

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)