;;; Copyright (c) 1991, 1994 Free Software Foundation, Inc.
-;; Author: Jamie Zawinski <jwz@jwz.org>
-;; Hallvard Furuseth <hbf@ulrik.uio.no>
+;; Authors: Jamie Zawinski <jwz@jwz.org>
+;; Hallvard Furuseth <hbf@ulrik.uio.no>
+;; Martin Buchholz <martin@xemacs.org>
;; Keywords: internal
;; This file is part of XEmacs.
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
-;;; Synched up with: FSF 20.7.
+;;; Synched up with: FSF 20.7 except where marked.
+;;; [[ Synched up with: FSF 20.7. ]]
+;;; DO NOT PUT IN AN INVALID SYNC MESSAGE WHEN YOU DO A PARTIAL SYNC. --ben
+
+;; BEGIN SYNC WITH 20.7.
;;; Commentary:
(compiled-function-constants fn)
(compiled-function-stack-depth fn)))
(cdr form)))
- (if (not (eq (car fn) 'lambda)) (error "%s is not a lambda" name))
- (cons fn (cdr form)))))))
+ (if (eq (car-safe fn) 'lambda)
+ (cons fn (cdr form))
+ ;; Give up on inlining.
+ form))))))
;;; ((lambda ...) ...)
;;;
(byte-compile-warn
"attempt to open-code %s with too many arguments" name))
form)
+ ;; This line, introduced in v1.10, can cause an infinite
+ ;; recursion when inlining recursive defsubst's
+; (setq body (mapcar 'byte-optimize-form body))
(let ((newform
(if bindings
(cons 'let (cons (nreverse bindings) body))
(if (and (cdr form) (null backwards))
(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))))
+ (when 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)))))
((eq fn 'interactive)
byte-compile-macro-environment))))
(byte-optimize-form form for-effect))
+ ;; Support compiler macros as in cl.el.
+ ((and (fboundp 'compiler-macroexpand)
+ (symbolp (car-safe form))
+ (get (car-safe form) 'cl-compiler-macro)
+ (not (eq form
+ (setq form (compiler-macroexpand form)))))
+ (byte-optimize-form form for-effect))
+
((not (symbolp fn))
(or (eq 'mocklisp (car-safe fn)) ; ha!
(byte-compile-warn "%s is a malformed function"
(list (apply fun (nreverse constants)))))))))
form))
-(defun byte-optimize-plus (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) ; (+)
- (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 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))))
+;; END SYNC WITH 20.7.
- (t (byte-optimize-predicate form))))
+;;; It is not safe to optimize calls to arithmetic ops with one arg
+;;; away entirely (actually, it would be safe if we know the sole arg
+;;; is not a marker or if it appears in other arithmetic).
-(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 an integer.
- (let ((last (last (nthcdr 3 form))))
- (cond ((eq 0 last)
- ;; (- x y ... 0) --> (- x y ...)
- (setq form (copy-sequence form))
- (setcdr (cdr (cdr form)) (delq 0 (nthcdr 3 form))))
- ;; If form is (- CONST foo... CONST), merge first and last.
- ((and (numberp (nth 1 form))
- (numberp last))
- (setq form (nconc (list '- (- (nth 1 form) last) (nth 2 form))
- (delq last (copy-sequence (nthcdr 3 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))))
+;;; But this degree of paranoia is normally unjustified, so optimize unless
+;;; the user has done (declaim (optimize (safety 3))). See bytecomp.el.
- (t (byte-optimize-predicate form))))
+(defun byte-optimize-plus (form)
+ (byte-optimize-predicate (byte-optimize-delay-constants-math form 1 '+)))
(defun byte-optimize-multiply (form)
(setq form (byte-optimize-delay-constants-math form 1 '*))
;; 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 (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)))))))
+
+ (case (car (last form))
+ ;; (* x y 0) --> (progn x y 0)
+ (0 (cons 'progn (cdr form)))
+ (t (byte-optimize-predicate form))))
+
+(defun byte-optimize-minus (form)
+ ;; Put constants at the end, except the first arg.
+ (setq form (byte-optimize-delay-constants-math form 2 '+))
+ ;; Now only the first and last args can be integers.
+ (let ((last (car (last (nthcdr 3 form)))))
+ (cond
+ ;; If form is (- CONST foo... CONST), merge first and last.
+ ((and (numberp (nth 1 form)) (numberp last))
+ (decf (nth 1 form) last)
+ (butlast form))
+
+ ;; (- 0 ...) -->
+ ((eq 0 (nth 1 form))
+ (case (length form)
+ ;; (- 0) --> 0
+ (2 0)
+ ;; (- 0 x) --> (- x)
+ (3 `(- ,(nth 2 form)))
+ ;; (- 0 x y ...) --> (- (- x) y ...)
+ (t `(- (- ,(nth 2 form)) ,@(nthcdr 3 form)))))
+
+ (t (byte-optimize-predicate form)))))
(defun byte-optimize-divide (form)
+ ;; Put constants at the end, except the first arg.
(setq form (byte-optimize-delay-constants-math form 2 '*))
- ;; 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))
- (not (zerop last))
- (condition-case nil
- (/ (nth 1 form) last)
- (error nil)))
- (setq form (list 'progn (/ (nth 1 form) last)))))
- ((= last 1)
- (setq form (butlast form)))
- ((numberp (nth 1 form))
- (setq form (cons (car form)
- (cons (/ (nth 1 form) last)
- (butlast (cdr (cdr form)))))
- last nil))))
+ ;; Now only the first and last args can be integers.
+ (let ((last (car (last (nthcdr 3 form)))))
(cond
-;;; ((null (cdr (cdr form)))
-;;; (nth 1 form))
+ ;; If form is (/ CONST foo... CONST), merge first and last.
+ ((and (numberp (nth 1 form)) (numberp last))
+ (condition-case nil
+ (cons (nth 0 form)
+ (cons (/ (nth 1 form) last)
+ (butlast (cdr (cdr form)))))
+ (error form)))
+
+ ;; (/ 0 x y) --> (progn x y 0)
((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))))
+
+ ;; We don't have to check for divide-by-zero because `/' does.
+ (t (byte-optimize-predicate form)))))
+
+;; BEGIN SYNC WITH 20.7.
(defun byte-optimize-logmumble (form)
(setq form (byte-optimize-delay-constants-math form 1 (car form)))
(setq ok (byte-compile-constp (car rest))
rest (cdr rest)))
(if ok
- (condition-case ()
+ (condition-case err
(list 'quote (eval form))
- (error form))
+ (error
+ (byte-compile-warn "evaluating %s: %s" form err)
+ form))
form)))
(defun byte-optimize-identity (form)
(put '* 'byte-optimizer 'byte-optimize-multiply)
(put '- 'byte-optimizer 'byte-optimize-minus)
(put '/ 'byte-optimizer 'byte-optimize-divide)
+(put '% 'byte-optimizer 'byte-optimize-predicate)
(put 'max 'byte-optimizer 'byte-optimize-associative-math)
(put 'min 'byte-optimizer 'byte-optimize-associative-math)
-(put '= 'byte-optimizer 'byte-optimize-binary-predicate)
(put 'eq 'byte-optimizer 'byte-optimize-binary-predicate)
(put 'eql 'byte-optimizer 'byte-optimize-binary-predicate)
(put 'equal 'byte-optimizer 'byte-optimize-binary-predicate)
(put 'string= 'byte-optimizer 'byte-optimize-binary-predicate)
(put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate)
+(put '= 'byte-optimizer 'byte-optimize-predicate)
(put '< 'byte-optimizer 'byte-optimize-predicate)
(put '> 'byte-optimizer 'byte-optimize-predicate)
(put '<= 'byte-optimizer 'byte-optimize-predicate)
(byte-optimize-predicate form)
(nth 1 form))))
+;; END SYNC WITH 20.7.
+
+;;; For the byte optimizer, `cond' is just overly sweet syntactic sugar.
+;;; So we rewrite (cond ...) in terms of `if' and `or',
+;;; which are easier to optimize.
(defun byte-optimize-cond (form)
- ;; if any clauses have a literal nil as their test, throw them away.
- ;; if any clause has a literal non-nil constant as its test, throw
- ;; away all following clauses.
- (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 rest form)
- (while (setq rest (cdr rest))
- (cond ((byte-compile-trueconstp (car-safe (car rest)))
- (cond ((eq rest (cdr form))
- (setq form
- (if (cdr (car rest))
- (if (cdr (cdr (car rest)))
- (cons 'progn (cdr (car rest)))
- (nth 1 (car rest)))
- (car (car rest)))))
- ((cdr rest)
- (setq form (copy-sequence form))
- (setcdr (memq (car rest) form) nil)))
- (setq rest nil)))))
- ;;
- ;; Turn (cond (( <x> )) ... ) into (or <x> (cond ... ))
- (if (eq 'cond (car-safe form))
- (let ((clauses (cdr form)))
- (if (and (consp (car clauses))
- (null (cdr (car clauses))))
- (list 'or (car (car clauses))
- (byte-optimize-cond
- (cons (car form) (cdr (cdr form)))))
- form))
- form))
+ (byte-optimize-cond-1 (cdr form)))
+
+(defun byte-optimize-cond-1 (clauses)
+ (cond
+ ((null clauses) nil)
+ ((consp (car clauses))
+ (nconc
+ (case (length (car clauses))
+ (1 `(or ,(nth 0 (car clauses))))
+ (2 `(if ,(nth 0 (car clauses)) ,(nth 1 (car clauses))))
+ (t `(if ,(nth 0 (car clauses)) (progn ,@(cdr (car clauses))))))
+ (when (cdr clauses) (list (byte-optimize-cond-1 (cdr clauses))))))
+ (t (error "malformed cond clause %s" (car clauses)))))
+
+;; BEGIN SYNC WITH 20.7.
(defun byte-optimize-if (form)
;; (if <true-constant> <then> <else...>) ==> <then>
(put 'if 'byte-optimizer 'byte-optimize-if)
(put 'while 'byte-optimizer 'byte-optimize-while)
-;; Remove any reason for avoiding `char-before'.
-(defun byte-optimize-char-before (form)
- `(char-after (1- ,(or (nth 1 form) '(point))) ,@(cdr (cdr form))))
+;; The supply of bytecodes is small and constrained by backward compatibility.
+;; Several functions have byte-coded versions and hence are very efficient.
+;; Related functions which can be expressed in terms of the byte-coded
+;; ones should be transformed into bytecoded calls for efficiency.
+;; This is especially the case for functions with a backward- and
+;; forward- version, but with a bytecode only for the forward one.
-(put 'char-before 'byte-optimizer 'byte-optimize-char-before)
+;; Some programmers have hand-optimized calls like (backward-char)
+;; into the call (forward-char -1).
+;; But it's so much nicer for the byte-compiler to do this automatically!
+
+;; (char-before) ==> (char-after (1- (point)))
+(put 'char-before 'byte-optimizer 'byte-optimize-char-before)
+(defun byte-optimize-char-before (form)
+ `(char-after
+ ,(cond
+ ((null (nth 1 form))
+ '(1- (point)))
+ ((equal '(point) (nth 1 form))
+ '(1- (point)))
+ (t `(1- (or ,(nth 1 form) (point)))))
+ ,@(cdr (cdr form))))
+
+;; (backward-char n) ==> (forward-char (- n))
+(put 'backward-char 'byte-optimizer 'byte-optimize-backward-char)
+(defun byte-optimize-backward-char (form)
+ `(forward-char
+ ,(typecase (nth 1 form)
+ (null -1)
+ (integer (- (nth 1 form)))
+ (t `(- (or ,(nth 1 form) 1))))
+ ,@(cdr (cdr form))))
+
+;; (backward-word n) ==> (forward-word (- n))
+(put 'backward-word 'byte-optimizer 'byte-optimize-backward-word)
+(defun byte-optimize-backward-word (form)
+ `(forward-word
+ ,(typecase (nth 1 form)
+ (null -1)
+ (integer (- (nth 1 form)))
+ (t `(- (or ,(nth 1 form) 1))))
+ ,@(cdr (cdr form))))
+
+;; The following would be a valid optimization of the above kind, but
+;; the gain in performance is very small, since the saved funcall is
+;; counterbalanced by the necessity of adding a bytecode for (point).
+;;
+;; Also, users are more likely to have modified the behavior of
+;; delete-char via advice or some similar mechanism. This is much
+;; less of a problem for the previous functions because it wouldn't
+;; make sense to modify the behaviour of `backward-char' without also
+;; modifying `forward-char', for example.
+
+;; (delete-char n) ==> (delete-region (point) (+ (point) n))
+;; (put 'delete-char 'byte-optimizer 'byte-optimize-delete-char)
+;; (defun byte-optimize-delete-char (form)
+;; (case (length (cdr form))
+;; (0 `(delete-region (point) (1+ (point))))
+;; (1 `(delete-region (point) (+ (point) ,(nth 1 form))))
+;; (t form)))
;; byte-compile-negation-optimizer lives in bytecomp.el
;(put '/= 'byte-optimizer 'byte-compile-negation-optimizer)
(put 'atom 'byte-optimizer 'byte-compile-negation-optimizer)
(put 'nlistp 'byte-optimizer 'byte-compile-negation-optimizer)
-
(defun byte-optimize-funcall (form)
;; (funcall '(lambda ...) ...) ==> ((lambda ...) ...)
;; (funcall 'foo ...) ==> (foo ...)
(defun byte-compile-splice-in-already-compiled-code (form)
;; form is (byte-code "..." [...] n)
- (if (not (memq byte-optimize '(t lap)))
+ (if (not (memq byte-optimize '(t byte)))
(byte-compile-normal-call form)
(byte-inline-lapcode
(byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t))
tags)))))))
((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t)
((memq op byte-constref-ops)))
- (setq tmp (aref constvec offset)
+ (setq tmp (if (>= offset (length constvec))
+ (list 'out-of-range offset)
+ (aref constvec offset))
offset (if (eq op 'byte-constant)
(byte-compile-get-constant tmp)
(or (assq tmp byte-compile-variables)
;;; variables.
;(defconst byte-boolean-vars
-; '(abbrev-all-caps purify-flag find-file-compare-truenames
-; find-file-use-truenames delete-auto-save-files byte-metering-on
-; x-seppuku-on-epipe zmacs-regions zmacs-region-active-p
-; zmacs-region-stays atomic-extent-goto-char-p
-; suppress-early-error-handler-backtrace noninteractive
-; inhibit-early-packages inhibit-autoloads debug-paths
-; inhibit-site-lisp debug-on-quit debug-on-next-call
-; modifier-keys-are-sticky x-allow-sendevents
-; mswindows-dynamic-frame-resize focus-follows-mouse
-; inhibit-input-event-recording enable-multibyte-characters
-; disable-auto-save-when-buffer-shrinks
-; allow-deletion-of-last-visible-frame indent-tabs-mode
-; load-in-progress load-warn-when-source-newer
-; load-warn-when-source-only load-ignore-elc-files
-; load-force-doc-strings fail-on-bucky-bit-character-escapes
-; popup-menu-titles menubar-show-keybindings completion-ignore-case
-; canna-empty-info canna-through-info canna-underline
-; canna-inhibit-hankakukana enable-multibyte-characters
-; re-short-flag x-handle-non-fully-specified-fonts
-; print-escape-newlines print-readably delete-exited-processes
-; windowed-process-io visible-bell no-redraw-on-reenter
-; cursor-in-echo-area inhibit-warning-display
-; column-number-start-at-one parse-sexp-ignore-comments
-; words-include-escapes scroll-on-clipped-lines)
-; "DEFVAR_BOOL variables. Giving these any non-nil value sets them to t.
-;If this does not enumerate all DEFVAR_BOOL variables, the byte-optimizer
-;may generate incorrect code.")
+; ...)
(defun byte-optimize-lapcode (lap &optional for-effect)
"Simple peephole optimizer. LAP is both modified and returned."
(while rest
(setq lap0 (car rest)
lap1 (nth 1 rest))
- (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))))
+ (if (memq (car lap0) byte-constref-ops)
+ (if (not (eq (car lap0) 'byte-constant))
+ (progn
+ (incf (gethash (cdr lap0) variable-frequency 0))
+ (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)))))
(cond (;;
;; const-C varset-X const-C --> const-C dup varset-X
;; const-C varbind-X const-C --> const-C dup varbind-X
byte-optimize-lapcode))))
nil)
+;; END SYNC WITH 20.7.
+
;;; byte-optimize.el ends here
projects / chise / xemacs-chise.git.1 / blobdiff