;; 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 ...))
(byte-compile-log
" all subforms of %s called for effect; deleted" form))
(and backwards
+ ;; Now optimize the rest of the forms. We need the return
+ ;; values. We already did the car.
+ (setcdr backwards
+ (mapcar 'byte-optimize-form (cdr backwards)))
(cons fn (nreverse backwards))))
(cons fn (mapcar 'byte-optimize-form (cdr form)))))
(setq form (byte-optimize-delay-constants-math form 1 '+))
(if (memq 0 form) (setq form (delq 0 (copy-sequence form))))
;;(setq form (byte-optimize-associative-two-args-math form))
+
(case (length (cdr form))
- ((0)
+ ((0) ; (+)
(condition-case ()
(eval form)
(error form)))
- ;; `add1' and `sub1' are a marginally fewer instructions
- ;; than `plus' and `minus', so use them when possible.
- ((2)
- (cond
- ((eq (nth 1 form) 1) `(1+ ,(nth 2 form))) ; (+ 1 x) --> (1+ x)
- ((eq (nth 2 form) 1) `(1+ ,(nth 1 form))) ; (+ x 1) --> (1+ x)
- ((eq (nth 1 form) -1) `(1- ,(nth 2 form))) ; (+ -1 x) --> (1- x)
- ((eq (nth 2 form) -1) `(1- ,(nth 1 form))) ; (+ x -1) --> (1- x)
- (t form)))
-
;; It is not safe to delete the function entirely
- ;; (actually, it would be safe if we know the sole arg
+ ;; (actually, it would be safe if we knew the sole arg
;; is not a marker).
- ;; ((null (cdr (cdr form))) (nth 1 form))
- (t form)))
+ ;; ((1)
+ ;; (nth 1 form))
+
+ ((2) ; (+ x y)
+ (byte-optimize-predicate
+ (cond
+ ;; `add1' and `sub1' are a marginally fewer instructions
+ ;; than `plus' and `minus', so use them when possible.
+ ((eq (nth 1 form) 1) `(1+ ,(nth 2 form))) ; (+ 1 x) --> (1+ x)
+ ((eq (nth 2 form) 1) `(1+ ,(nth 1 form))) ; (+ x 1) --> (1+ x)
+ ((eq (nth 1 form) -1) `(1- ,(nth 2 form))) ; (+ -1 x) --> (1- x)
+ ((eq (nth 2 form) -1) `(1- ,(nth 1 form))) ; (+ x -1) --> (1- x)
+ (t form))))
+
+ (t (byte-optimize-predicate form))))
(defun byte-optimize-minus (form)
;; Put constants at the end, except the last constant.
(setq form (byte-optimize-delay-constants-math form 2 '+))
- ;; Now only first and last element can be a number.
- (let ((last (car (reverse (nthcdr 3 form)))))
+ ;; Now only first and last element can be an integer.
+ (let ((last (last (nthcdr 3 form))))
(cond ((eq 0 last)
;; (- x y ... 0) --> (- x y ...)
(setq form (copy-sequence form))
(numberp last))
(setq form (nconc (list '- (- (nth 1 form) last) (nth 2 form))
(delq last (copy-sequence (nthcdr 3 form))))))))
- (setq form
-;;; It is not safe to delete the function entirely
-;;; (actually, it would be safe if we know the sole arg
-;;; is not a marker).
-;;; (if (eq (nth 2 form) 0)
-;;; (nth 1 form) ; (- x 0) --> x
- (byte-optimize-predicate
- (if (and (null (cdr (cdr (cdr form))))
- (eq (nth 1 form) 0)) ; (- 0 x) --> (- x)
- (cons (car form) (cdr (cdr form)))
- form))
-;;; )
- )
-
- ;; `add1' and `sub1' are a marginally fewer instructions than `plus'
- ;; and `minus', so use them when possible.
- (cond ((and (null (nthcdr 3 form))
- (eq (nth 2 form) 1))
- (list '1- (nth 1 form))) ; (- x 1) --> (1- x)
- ((and (null (nthcdr 3 form))
- (eq (nth 2 form) -1))
- (list '1+ (nth 1 form))) ; (- x -1) --> (1+ x)
- (t
- form))
- )
+
+ (case (length (cdr form))
+ ((0) ; (-)
+ (condition-case ()
+ (eval form)
+ (error form)))
+
+ ;; It is not safe to delete the function entirely
+ ;; (actually, it would be safe if we knew the sole arg
+ ;; is not a marker).
+ ;; ((1)
+ ;; (nth 1 form)
+
+ ((2) ; (+ x y)
+ (byte-optimize-predicate
+ (cond
+ ;; `add1' and `sub1' are a marginally fewer instructions than `plus'
+ ;; and `minus', so use them when possible.
+ ((eq (nth 2 form) 1) `(1- ,(nth 1 form))) ; (- x 1) --> (1- x)
+ ((eq (nth 2 form) -1) `(1+ ,(nth 1 form))) ; (- x -1) --> (1+ x)
+ ((eq (nth 1 form) 0) `(- ,(nth 2 form))) ; (- 0 x) --> (- x)
+ (t form))))
+
+ (t (byte-optimize-predicate form))))
(defun byte-optimize-multiply (form)
(setq form (byte-optimize-delay-constants-math form 1 '*))
- ;; If there is a constant in FORM, it is now the last element.
+ ;; If there is a constant integer in FORM, it is now the last element.
(cond ((null (cdr form)) 1)
;;; It is not safe to delete the function entirely
;;; (actually, it would be safe if we know the sole arg
;;; is not a marker or if it appears in other arithmetic).
;;; ((null (cdr (cdr form))) (nth 1 form))
- ((let ((last (car (reverse form))))
- (cond ((eq 0 last) (cons 'progn (cdr form)))
- ((eq 1 last) (delq 1 (copy-sequence form)))
- ((eq -1 last) (list '- (delq -1 (copy-sequence form))))
- ((and (eq 2 last)
- (memq t (mapcar 'symbolp (cdr form))))
- (prog1 (setq form (delq 2 (copy-sequence form)))
- (while (not (symbolp (car (setq form (cdr form))))))
- (setcar form (list '+ (car form) (car form)))))
- (form))))))
+ ((let ((last (last form)))
+ (byte-optimize-predicate
+ (cond ((eq 0 last) (cons 'progn (cdr form)))
+ ((eq 1 last) (delq 1 (copy-sequence form)))
+ ((eq -1 last) (list '- (delq -1 (copy-sequence form))))
+ ((and (eq 2 last)
+ (memq t (mapcar 'symbolp (cdr form))))
+ (prog1 (setq form (delq 2 (copy-sequence form)))
+ (while (not (symbolp (car (setq form (cdr form))))))
+ (setcar form (list '+ (car form) (car form)))))
+ (form)))))))
(defun byte-optimize-divide (form)
(setq form (byte-optimize-delay-constants-math form 2 '*))
- (let ((last (car (reverse (cdr (cdr form))))))
+ ;; If there is a constant integer in FORM, it is now the last element.
+ (let ((last (last (cdr (cdr form)))))
(if (numberp last)
(cond ((= (length form) 3)
(if (and (numberp (nth 1 form))
(cond
;;; ((null (cdr (cdr form)))
;;; (nth 1 form))
- ((eq (nth 1 form) 0)
- (append '(progn) (cdr (cdr form)) '(0)))
- ((eq last -1)
- (list '- (if (nthcdr 3 form)
- (butlast form)
- (nth 1 form))))
- (form))))
+ ((eq (nth 1 form) 0)
+ (append '(progn) (cdr (cdr form)) '(0)))
+ ((eq last -1)
+ (list '- (if (nthcdr 3 form)
+ (butlast form)
+ (nth 1 form))))
+ (form))))
(defun byte-optimize-logmumble (form)
(setq form (byte-optimize-delay-constants-math form 1 (car form)))
(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)
projects / chise / xemacs-chise.git.1 / blobdiff