[Emacs-diffs] feature/gnus-select 5b0fed9 218/218: Fix constant folding of overflows

[Andrew G Cohen]

branch: feature/gnus-select
commit 5b0fed956e755eaf0b0dce148b3de39a390d1195
Author: Paul Eggert <address@hidden>
Commit: Andrew G Cohen <address@hidden>

    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 004f58c..3bc4c43 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -678,59 +678,134 @@
            (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 @@
 (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 @@
   ;; 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 @@
   (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)))