update.
[chise/xemacs-chise.git] / lisp / byte-optimize.el
index 2ab79db..6f9f8f4 100644 (file)
@@ -23,7 +23,7 @@
 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;; Boston, MA 02111-1307, USA.
 
-;;; Synched up with: FSF 19.30.
+;;; Synched up with: FSF 20.7.
 
 ;;; Commentary:
 
 ;;(disassemble #'(lambda (x) (eq (if (point) 'a 'b) 'c)))
 ;;(disassemble #'(lambda (x) (if (point) (eq 'a 'c) (eq 'b 'c))))
 
-;; (car (cons A B)) -> (progn B A)
+;; (car (cons A B)) -> (prog1 A B)
 ;;(disassemble #'(lambda (x) (car (cons (foo) 42))))
 
 ;; (cdr (cons A B)) -> (progn A B)
 ;;(disassemble #'(lambda (x) (cdr (cons 42 (foo)))))
 
-;; (car (list A B ...)) -> (progn B ... A)
+;; (car (list A B ...)) -> (prog1 A ... B)
 ;;(disassemble #'(lambda (x) (car (list (foo) 42 (bar)))))
 
 ;; (cdr (list A B ...)) -> (progn A (list B ...))
                       (if (= 1 (length (cdr form))) "" "s"))
     form))
 
+(defun byte-optimize-car (form)
+  (let ((arg (cadr form)))
+    (cond
+     ((and (byte-compile-trueconstp arg)
+          (not (and (consp arg)
+                    (eq (car arg) 'quote)
+                    (listp (cadr arg)))))
+      (byte-compile-warn
+       "taking car of a constant: %s" arg)
+      form)
+     ((and (eq (car-safe arg) 'cons)
+          (eq (length arg) 3))
+      `(prog1 ,(nth 1 arg) ,(nth 2 arg)))
+     ((eq (car-safe arg) 'list)
+      `(prog1 ,@(cdr arg)))
+     (t
+      (byte-optimize-predicate form)))))
+
+(defun byte-optimize-cdr (form)
+  (let ((arg (cadr form)))
+    (cond
+     ((and (byte-compile-trueconstp arg)
+          (not (and (consp arg)
+                    (eq (car arg) 'quote)
+                    (listp (cadr arg)))))
+      (byte-compile-warn
+       "taking cdr of a constant: %s" arg)
+      form)
+     ((and (eq (car-safe arg) 'cons)
+           (eq (length arg) 3))
+       `(progn ,(nth 1 arg) ,(nth 2 arg)))
+      ((eq (car-safe arg) 'list)
+       (if (> (length arg) 2)
+          `(progn ,(cadr arg) (list ,@(cddr arg)))
+        (cadr arg)))
+      (t
+       (byte-optimize-predicate form)))))
+
 (put 'identity 'byte-optimizer 'byte-optimize-identity)
 
 (put '+   'byte-optimizer 'byte-optimize-plus)
 (put 'logxor 'byte-optimizer 'byte-optimize-logmumble)
 (put 'lognot 'byte-optimizer 'byte-optimize-predicate)
 
-(put 'car 'byte-optimizer 'byte-optimize-predicate)
-(put 'cdr 'byte-optimizer 'byte-optimize-predicate)
+(put 'car 'byte-optimizer 'byte-optimize-car)
+(put 'cdr 'byte-optimizer 'byte-optimize-cdr)
 (put 'car-safe 'byte-optimizer 'byte-optimize-predicate)
 (put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate)
 
       (while (>= (setq count (1- count)) 0)
        (setq form (list 'cdr form)))
       form)))
+
+(put 'concat 'byte-optimizer 'byte-optimize-concat)
+(defun byte-optimize-concat (form)
+  (let ((args (cdr form))
+       (constant t))
+    (while (and args constant)
+      (or (byte-compile-constp (car args))
+         (setq constant nil))
+      (setq args (cdr args)))
+    (if constant
+       (eval form)
+      form)))
 \f
 ;;; enumerating those functions which need not be called if the returned
 ;;; value is not used.  That is, something like
         hash-table-p
         identity ignore integerp integer-or-marker-p interactive-p
         invocation-directory invocation-name
-        ;; keymapp may autoload in XEmacs, so not on this list!
-        list listp
+        keymapp list listp
         make-marker mark mark-marker markerp memory-limit minibuffer-window
         ;; mouse-movement-p not in XEmacs
         natnump nlistp not null number-or-marker-p numberp
   ;; fetch and return the offset for the current opcode.
   ;; return NIL if this opcode has no offset
   ;; OP, PTR and BYTES are used and set dynamically
-  (defvar op)
-  (defvar ptr)
-  (defvar bytes)
+  (declare (special op ptr bytes))
   (cond ((< op byte-nth)
         (let ((tem (logand op 7)))
           (setq op (logand op 248))
 (defconst byte-after-unbind-ops
    '(byte-constant byte-dup
      byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp
-     byte-eq byte-equal byte-not
+     byte-eq byte-not
      byte-cons byte-list1 byte-list2   ; byte-list3 byte-list4
      byte-interactive-p)
    ;; How about other side-effect-free-ops?  Is it safe to move an
    ;; error invocation (such as from nth) out of an unwind-protect?
+   ;; No, it is not, because the unwind-protect forms can alter
+   ;; the inside of the object to which nth would apply.
+   ;; For the same reason, byte-equal was deleted from this list.
    "Byte-codes that can be moved past an unbind.")
 
 (defconst byte-compile-side-effect-and-error-free-ops
 
 (defun byte-optimize-lapcode (lap &optional for-effect)
   "Simple peephole optimizer.  LAP is both modified and returned."
-  (let (lap0 ;; off0 unused
-       lap1 ;; off1
-       lap2 ;; off2
+  (let (lap0
+       lap1
+       lap2
+       variable-frequency
        (keep-going 'first-time)
        (add-depth 0)
        rest tmp tmp2 tmp3
     ;; Rebuild byte-compile-constants / byte-compile-variables.
     ;; Simple optimizations that would inhibit other optimizations if they
     ;; were done in the optimizing loop, and optimizations which there is no
-    ;;  need to do more than once.
+    ;; need to do more than once.
     (setq byte-compile-constants nil
-         byte-compile-variables nil)
+         byte-compile-variables nil
+         variable-frequency (make-hash-table :test 'eq))
     (setq rest lap)
     (while rest
       (setq lap0 (car rest)
            lap1 (nth 1 rest))
-      (if (memq (car lap0) byte-constref-ops)
-         (if (eq (cdr lap0) 'byte-constant)
-             (or (memq (cdr lap0) byte-compile-variables)
-                 (setq byte-compile-variables (cons (cdr lap0)
-                                                    byte-compile-variables)))
-           (or (memq (cdr lap0) byte-compile-constants)
-               (setq byte-compile-constants (cons (cdr lap0)
-                                                  byte-compile-constants)))))
+      (case (car lap0)
+       ((byte-varref byte-varset byte-varbind)
+        (incf (gethash (cdr lap0) variable-frequency 0))
+        (unless (memq (cdr lap0) byte-compile-variables)
+          (push (cdr lap0) byte-compile-variables)))
+       ((byte-constant)
+        (unless (memq (cdr lap0) byte-compile-constants)
+          (push (cdr lap0) byte-compile-constants))))
       (cond (;;
-            ;; const-C varset-X const-C  -->  const-C dup varset-X
+            ;; const-C varset-X  const-C  -->  const-C dup varset-X
             ;; const-C varbind-X const-C  -->  const-C dup varbind-X
             ;;
             (and (eq (car lap0) 'byte-constant)
                  (eq (car (nth 2 rest)) 'byte-constant)
-                 (eq (cdr lap0) (car (nth 2 rest)))
+                 (eq (cdr lap0) (cdr (nth 2 rest)))
                  (memq (car lap1) '(byte-varbind byte-varset)))
             (byte-compile-log-lap "  %s %s %s\t-->\t%s dup %s"
                                   lap0 lap1 lap0 lap0 lap1)
             (setcdr lap1 (+ (cdr lap1) (cdr lap0))))
            )
       (setq rest (cdr rest)))
+    ;; Since the first 6 entries of the compiled-function constants
+    ;; vector are most efficient for varref/set/bind ops, we sort by
+    ;; reference count.  This generates maximally space efficient and
+    ;; pretty time-efficient byte-code.  See `byte-compile-constants-vector'.
+    (setq byte-compile-variables
+         (sort byte-compile-variables
+               #'(lambda (v1 v2)
+                   (< (gethash v1 variable-frequency)
+                      (gethash v2 variable-frequency)))))
+    ;; Another hack - put the most used variable in position 6, for
+    ;; better locality of reference with adjoining constants.
+    (let ((tail (last byte-compile-variables 6)))
+      (setq byte-compile-variables
+           (append (nbutlast byte-compile-variables 6)
+                   (nreverse tail))))
     (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
   lap)