Re: Floating-point constant folding in Emacs byte compiler

[Paul Eggert <eggert@cs.ucla.edu>]

[-- Attachment #1: Type: text/plain, Size: 378 bytes --]

On 03/26/2018 10:52 AM, Stefan Monnier wrote:
> I think TRT is for the byte-compiler to refrain from performing this
> optimization when the result doesn't fit within 30bits.

Yes, this seems like the right way to go for Emacs, since we value 
reproducibility and safety over performance for numeric computation. I 
installed the attached patch into master, to try to do that.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Fix-constant-folding-of-overflows.patch --]
[-- Type: text/x-patch; name="0001-Fix-constant-folding-of-overflows.patch", Size: 10156 bytes --]

From e3b742dcc3d2f1946969d87839e3b72b0f52c513 Mon Sep 17 00:00:00 2001
From: Paul Eggert <eggert@cs.ucla.edu>
Date: Mon, 26 Mar 2018 17:03:54 -0700
Subject: [PATCH] Fix constant folding of overflows

This suppresses some byte-code optimizations that were invalid in
the presence of integer overflows, because they meant that .elc
files assumed the runtime behavior of the compiling platform, as
opposed to the runtime platform.  Problem reported by Pip Cet in:
https://lists.gnu.org/r/emacs-devel/2018-03/msg00753.html
* lisp/emacs-lisp/byte-opt.el (byte-opt--portable-max)
(byte-opt--portable-min): New constants.
(byte-opt--portable-numberp, byte-opt--arith-reduce)
(byte-optimize-1+, byte-optimize-1-): New functions.
(byte-optimize-plus, byte-optimize-minus, byte-optimize-multiply)
(byte-optimize-divide):	Avoid invalid optimizations.
(1+, 1-): Use new optimizers.
(byte-optimize-or, byte-optimize-cond): Simplify by using
remq instead of delq and copy-sequence.
---
 lisp/emacs-lisp/byte-opt.el | 175 +++++++++++++++++++++++++++++++-------------
 1 file changed, 124 insertions(+), 51 deletions(-)

diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index 004f58cc12..3bc4c438d6 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -678,59 +678,134 @@ byte-optimize-associative-math
 	    (apply (car form) constants))
 	form)))
 
+;; Portable Emacs integers fall in this range.
+(defconst byte-opt--portable-max #x1fffffff)
+(defconst byte-opt--portable-min (- -1 byte-opt--portable-max))
+
+;; True if N is a number that works the same on all Emacs platforms.
+;; Portable Emacs fixnums are exactly representable as floats on all
+;; Emacs platforms, and (except for -0.0) any floating-point number
+;; that equals one of these integers must be the same on all
+;; platforms.  Although other floating-point numbers such as 0.5 are
+;; also portable, it can be tricky to characterize them portably so
+;; they are not optimized.
+(defun byte-opt--portable-numberp (n)
+  (and (numberp n)
+       (<= byte-opt--portable-min n byte-opt--portable-max)
+       (= n (floor n))
+       (not (and (floatp n) (zerop n)
+                 (condition-case () (< (/ n) 0) (error))))))
+
+;; Use OP to reduce any leading prefix of portable numbers in the list
+;; (cons ACCUM ARGS) down to a single portable number, and return the
+;; resulting list A of arguments.  The idea is that applying OP to A
+;; is equivalent to (but likely more efficient than) applying OP to
+;; (cons ACCUM ARGS), on any Emacs platform.  Do not make any special
+;; provision for (- X) or (/ X); for example, it is the caller’s
+;; responsibility that (- 1 0) should not be "optimized" to (- 1).
+(defun byte-opt--arith-reduce (op accum args)
+  (when (byte-opt--portable-numberp accum)
+    (let (accum1)
+      (while (and (byte-opt--portable-numberp (car args))
+                  (byte-opt--portable-numberp
+                   (setq accum1 (condition-case ()
+                                    (funcall op accum (car args))
+                                  (error))))
+                  (= accum1 (funcall op (float accum) (car args))))
+        (setq accum accum1)
+        (setq args (cdr args)))))
+  (cons accum args))
+
 (defun byte-optimize-plus (form)
-  (if (memq 0 form) (setq form (delq 0 (copy-sequence form))))
-  ;; For (+ constants...), byte-optimize-predicate does the work.
-  (when (memq nil (mapcar 'numberp (cdr form)))
+  (let ((args (remq 0 (byte-opt--arith-reduce #'+ 0 (cdr form)))))
     (cond
+     ;; (+) -> 0
+     ((null args) 0)
+     ;; (+ n) -> n, where n is a number
+     ((and (null (cdr args)) (numberp (car args))) (car args))
      ;; (+ x 1) --> (1+ x) and (+ x -1) --> (1- x).
-     ((and (= (length form) 3)
-	   (or (memq (nth 1 form) '(1 -1))
-	       (memq (nth 2 form) '(1 -1))))
-      (let (integer other)
-	(if (memq (nth 1 form) '(1 -1))
-	    (setq integer (nth 1 form) other (nth 2 form))
-	  (setq integer (nth 2 form) other (nth 1 form)))
-	(setq form
-	      (list (if (eq integer 1) '1+ '1-) other))))))
-  (byte-optimize-predicate form))
+     ((and (null (cddr args)) (or (memq 1 args) (memq -1 args)))
+      (let* ((arg1 (car args)) (arg2 (cadr args))
+             (integer-is-first (memq arg1 '(1 -1)))
+             (integer (if integer-is-first arg1 arg2))
+             (other (if integer-is-first arg2 arg1)))
+        (list (if (eq integer 1) '1+ '1-) other)))
+     ;; not further optimized
+     ((equal args (cdr form)) form)
+     (t (cons '+ args)))))
 
 (defun byte-optimize-minus (form)
-  ;; Remove zeros.
-  (when (and (nthcdr 3 form)
-	     (memq 0 (cddr form)))
-    (setq form (nconc (list (car form) (cadr form))
-		      (delq 0 (copy-sequence (cddr form)))))
-    ;; After the above, we must turn (- x) back into (- x 0).
-    (or (cddr form)
-	(setq form (nconc form (list 0)))))
-  ;; For (- constants...), byte-optimize-predicate does the work.
-  (when (memq nil (mapcar 'numberp (cdr form)))
-    (cond
-     ;; (- x 1) --> (1- x)
-     ((equal (nthcdr 2 form) '(1))
-      (setq form (list '1- (nth 1 form))))
-     ;; (- x -1) --> (1+ x)
-     ((equal (nthcdr 2 form) '(-1))
-      (setq form (list '1+ (nth 1 form))))))
-  (byte-optimize-predicate form))
+  (let ((args (cdr form)))
+    (if (and (cdr args)
+             (null (cdr (setq args (byte-opt--arith-reduce
+                                    #'- (car args) (cdr args)))))
+             (numberp (car args)))
+        ;; The entire argument list reduced to a constant; return it.
+        (car args)
+      ;; Remove non-leading zeros, except for (- x 0).
+      (when (memq 0 (cdr args))
+        (setq args (cons (car args) (or (remq 0 (cdr args)) (list 0)))))
+      (cond
+       ;; (- x 1) --> (1- x)
+       ((equal (cdr args) '(1))
+        (list '1- (car args)))
+       ;; (- x -1) --> (1+ x)
+       ((equal (cdr args) '(-1))
+        (list '1+ (car args)))
+       ;; (- n) -> -n, where n and -n are portable numbers.
+       ;; This must be done separately since byte-opt--arith-reduce
+       ;; is not applied to (- n).
+       ((and (null (cdr args))
+             (byte-opt--portable-numberp (car args))
+             (byte-opt--portable-numberp (- (car args))))
+        (- (car args)))
+       ;; not further optimized
+       ((equal args (cdr form)) form)
+       (t (cons '- args))))))
+
+(defun byte-optimize-1+ (form)
+  (let ((args (cdr form)))
+    (when (null (cdr args))
+      (let ((n (car args)))
+        (when (and (byte-opt--portable-numberp n)
+                   (byte-opt--portable-numberp (1+ n)))
+          (setq form (1+ n))))))
+  form)
+
+(defun byte-optimize-1- (form)
+  (let ((args (cdr form)))
+    (when (null (cdr args))
+      (let ((n (car args)))
+        (when (and (byte-opt--portable-numberp n)
+                   (byte-opt--portable-numberp (1- n)))
+          (setq form (1- n))))))
+  form)
 
 (defun byte-optimize-multiply (form)
-  (if (memq 1 form) (setq form (delq 1 (copy-sequence form))))
-  ;; For (* integers..), byte-optimize-predicate does the work.
-  (byte-optimize-predicate form))
+  (let* ((args (remq 1 (byte-opt--arith-reduce #'* 1 (cdr form)))))
+    (cond
+     ;; (*) -> 1
+     ((null args) 1)
+     ;; (* n) -> n, where n is a number
+     ((and (null (cdr args)) (numberp (car args))) (car args))
+     ;; not further optimized
+     ((equal args (cdr form)) form)
+     (t (cons '* args)))))
 
 (defun byte-optimize-divide (form)
-  ;; Remove 1s.
-  (when (and (nthcdr 3 form)
-	     (memq 1 (cddr form)))
-    (setq form (nconc (list (car form) (cadr form))
-		      (delq 1 (copy-sequence (cddr form)))))
-    ;; After the above, we must turn (/ x) back into (/ x 1).
-    (or (cddr form)
-	(setq form (nconc form (list 1)))))
-  (byte-optimize-predicate form))
-
+  (let ((args (cdr form)))
+    (if (and (cdr args)
+             (null (cdr (setq args (byte-opt--arith-reduce
+                                    #'/ (car args) (cdr args)))))
+             (numberp (car args)))
+        ;; The entire argument list reduced to a constant; return it.
+        (car args)
+      ;; Remove non-leading 1s, except for (/ x 1).
+      (when (memq 1 (cdr args))
+        (setq args (cons (car args) (or (remq 1 (cdr args)) (list 1)))))
+      (if (equal args (cdr form))
+          form
+        (cons '/ args)))))
 
 (defun byte-optimize-binary-predicate (form)
   (cond
@@ -800,8 +875,8 @@ byte-optimize-memq
 (put '>   'byte-optimizer 'byte-optimize-predicate)
 (put '<=  'byte-optimizer 'byte-optimize-predicate)
 (put '>=  'byte-optimizer 'byte-optimize-predicate)
-(put '1+  'byte-optimizer 'byte-optimize-predicate)
-(put '1-  'byte-optimizer 'byte-optimize-predicate)
+(put '1+  'byte-optimizer 'byte-optimize-1+)
+(put '1-  'byte-optimizer 'byte-optimize-1-)
 (put 'not 'byte-optimizer 'byte-optimize-predicate)
 (put 'null  'byte-optimizer 'byte-optimize-predicate)
 (put 'consp 'byte-optimizer 'byte-optimize-predicate)
@@ -854,8 +929,7 @@ byte-optimize-or
   ;; Throw away nil's, and simplify if less than 2 args.
   ;; If there is a literal non-nil constant in the args to `or', throw away all
   ;; following forms.
-  (if (memq nil form)
-      (setq form (delq nil (copy-sequence form))))
+  (setq form (remq nil form))
   (let ((rest form))
     (while (cdr (setq rest (cdr rest)))
       (if (byte-compile-trueconstp (car rest))
@@ -872,9 +946,8 @@ byte-optimize-cond
   (let (rest)
     ;; This must be first, to reduce (cond (t ...) (nil)) to (progn t ...)
     (while (setq rest (assq nil (cdr form)))
-      (setq form (delq rest (copy-sequence form))))
-    (if (memq nil (cdr form))
-	(setq form (delq nil (copy-sequence form))))
+      (setq form (remq rest form)))
+    (setq form (remq nil form))
     (setq rest form)
     (while (setq rest (cdr rest))
       (cond ((byte-compile-trueconstp (car-safe (car rest)))
-- 
2.14.3