procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

(byte-compile-log-lap, byte-compile-inline-expand): Use backquote.

Browse source 
(byte-optimize-pure-func): Rename from byte-optimize-concat.
(symbol-name, regexp-opt, regexp-quote): Mark as pure.
This commit is contained in:
Stefan Monnier 2004-03-22 15:21:08 +00:00
parent 1de9630d9b
commit e856a453a1
1 changed files with 122 additions and 115 deletions
Download patch file Download diff file Expand all files Collapse all files

237
lisp/emacs-lisp/byte-opt.el
View file

@ -1,6 +1,6 @@
;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler ;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler
;;; Copyright (c) 1991, 1994, 2000, 2001, 2002 Free Software Foundation, Inc. ;; Copyright (c) 1991,1994,2000,01,02,2004 Free Software Foundation, Inc.
;; Author: Jamie Zawinski <jwz@lucid.com> ;; Author: Jamie Zawinski <jwz@lucid.com>
;; Hallvard Furuseth <hbf@ulrik.uio.no> ;; Hallvard Furuseth <hbf@ulrik.uio.no>
@ -148,37 +148,37 @@
;; Other things to consider: ;; Other things to consider:
;;;;; Associative math should recognize subcalls to identical function: ;; ;; Associative math should recognize subcalls to identical function:
;;;(disassemble (lambda (x) (+ (+ (foo) 1) (+ (bar) 2)))) ;; (disassemble (lambda (x) (+ (+ (foo) 1) (+ (bar) 2))))
;;;;; This should generate the same as (1+ x) and (1- x) ;; ;; This should generate the same as (1+ x) and (1- x)
;;;(disassemble (lambda (x) (cons (+ x 1) (- x 1)))) ;; (disassemble (lambda (x) (cons (+ x 1) (- x 1))))
;;;;; An awful lot of functions always return a non-nil value. If they're ;; ;; An awful lot of functions always return a non-nil value. If they're
;;;;; error free also they may act as true-constants. ;; ;; error free also they may act as true-constants.
;;;(disassemble (lambda (x) (and (point) (foo)))) ;; (disassemble (lambda (x) (and (point) (foo))))
;;;;; When ;; ;; When
;;;;; - all but one arguments to a function are constant ;; ;; - all but one arguments to a function are constant
;;;;; - the non-constant argument is an if-expression (cond-expression?) ;; ;; - the non-constant argument is an if-expression (cond-expression?)
;;;;; then the outer function can be distributed. If the guarding ;; ;; then the outer function can be distributed. If the guarding
;;;;; condition is side-effect-free [assignment-free] then the other ;; ;; condition is side-effect-free [assignment-free] then the other
;;;;; arguments may be any expressions. Since, however, the code size ;; ;; arguments may be any expressions. Since, however, the code size
;;;;; can increase this way they should be "simple". Compare: ;; ;; can increase this way they should be "simple". Compare:
;;;(disassemble (lambda (x) (eq (if (point) 'a 'b) 'c))) ;; (disassemble (lambda (x) (eq (if (point) 'a 'b) 'c)))
;;;(disassemble (lambda (x) (if (point) (eq 'a 'c) (eq '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)))) ;; (disassemble (lambda (x) (car (cons (foo) 42))))
;;;;; (cdr (cons A B)) -> (progn A B) ;; ;; (cdr (cons A B)) -> (progn A B)
;;;(disassemble (lambda (x) (cdr (cons 42 (foo))))) ;; (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))))) ;; (disassemble (lambda (x) (car (list (foo) 42 (bar)))))
;;;;; (cdr (list A B ...)) -> (progn A (list B ...)) ;; ;; (cdr (list A B ...)) -> (progn A (list B ...))
;;;(disassemble (lambda (x) (cdr (list 42 (foo) (bar))))) ;; (disassemble (lambda (x) (cdr (list 42 (foo) (bar)))))
;;; Code: ;;; Code:
@ -217,10 +217,8 @@
args))))) args)))))
(defmacro byte-compile-log-lap (format-string &rest args) (defmacro byte-compile-log-lap (format-string &rest args)
(list 'and `(and (memq byte-optimize-log '(t byte))
'(memq byte-optimize-log '(t byte)) (byte-compile-log-lap-1 ,format-string ,@args)))
(cons 'byte-compile-log-lap-1
(cons format-string args))))
;;; byte-compile optimizers to support inlining ;;; byte-compile optimizers to support inlining
@ -274,18 +272,18 @@
(let (string) (let (string)
(fetch-bytecode fn) (fetch-bytecode fn)
(setq string (aref fn 1)) (setq string (aref fn 1))
;; Isn't it an error for `string' not to be unibyte?? --stef
(if (fboundp 'string-as-unibyte) (if (fboundp 'string-as-unibyte)
(setq string (string-as-unibyte string))) (setq string (string-as-unibyte string)))
(cons (list 'lambda (aref fn 0) (cons `(lambda ,(aref fn 0)
(list 'byte-code string (aref fn 2) (aref fn 3))) (byte-code ,string ,(aref fn 2) ,(aref fn 3)))
(cdr form))) (cdr form)))
(if (eq (car-safe fn) 'lambda) (if (eq (car-safe fn) 'lambda)
(cons fn (cdr form)) (cons fn (cdr form))
;; Give up on inlining. ;; Give up on inlining.
form)))))) form))))))
;;; ((lambda ...) ...) ;; ((lambda ...) ...)
;;;
(defun byte-compile-unfold-lambda (form &optional name) (defun byte-compile-unfold-lambda (form &optional name)
(or name (setq name "anonymous lambda")) (or name (setq name "anonymous lambda"))
(let ((lambda (car form)) (let ((lambda (car form))
@ -604,14 +602,14 @@
(nreverse result))) (nreverse result)))
;;; some source-level optimizers ;; some source-level optimizers
;;; ;;
;;; when writing optimizers, be VERY careful that the optimizer returns ;; when writing optimizers, be VERY careful that the optimizer returns
;;; something not EQ to its argument if and ONLY if it has made a change. ;; something not EQ to its argument if and ONLY if it has made a change.
;;; This implies that you cannot simply destructively modify the list; ;; This implies that you cannot simply destructively modify the list;
;;; you must return something not EQ to it if you make an optimization. ;; you must return something not EQ to it if you make an optimization.
;;; ;;
;;; It is now safe to optimize code such that it introduces new bindings. ;; It is now safe to optimize code such that it introduces new bindings.
;; I'd like this to be a defsubst, but let's not be self-referential... ;; I'd like this to be a defsubst, but let's not be self-referential...
(defmacro byte-compile-trueconstp (form) (defmacro byte-compile-trueconstp (form)
@ -721,10 +719,10 @@
(condition-case () (condition-case ()
(eval form) (eval form)
(error form))) (error form)))
;;; It is not safe to delete the function entirely ;;; 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 know the sole arg
;;; is not a marker). ;;; is not a marker).
;; ((null (cdr (cdr form))) (nth 1 form)) ;;; ((null (cdr (cdr form))) (nth 1 form))
((null (cddr form)) ((null (cddr form))
(if (numberp (nth 1 form)) (if (numberp (nth 1 form))
(nth 1 form) (nth 1 form)
@ -763,9 +761,9 @@
(numberp last)) (numberp last))
(setq form (nconc (list '- (- (nth 1 form) last) (nth 2 form)) (setq form (nconc (list '- (- (nth 1 form) last) (nth 2 form))
(delq last (copy-sequence (nthcdr 3 form)))))))) (delq last (copy-sequence (nthcdr 3 form))))))))
;;; It is not safe to delete the function entirely ;;; 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 know the sole arg
;;; is not a marker). ;;; is not a marker).
;;; (if (eq (nth 2 form) 0) ;;; (if (eq (nth 2 form) 0)
;;; (nth 1 form) ; (- x 0) --> x ;;; (nth 1 form) ; (- x 0) --> x
(byte-optimize-predicate (byte-optimize-predicate
@ -780,9 +778,9 @@
(setq form (byte-optimize-delay-constants-math form 1 '*)) (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 in FORM, it is now the last element.
(cond ((null (cdr form)) 1) (cond ((null (cdr form)) 1)
;;; It is not safe to delete the function entirely ;;; 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 know the sole arg
;;; is not a marker or if it appears in other arithmetic). ;;; is not a marker or if it appears in other arithmetic).
;;; ((null (cdr (cdr form))) (nth 1 form)) ;;; ((null (cdr (cdr form))) (nth 1 form))
((let ((last (car (reverse form)))) ((let ((last (car (reverse form))))
(cond ((eq 0 last) (cons 'progn (cdr form))) (cond ((eq 0 last) (cons 'progn (cdr form)))
@ -1117,8 +1115,16 @@
(byte-optimize-predicate form)) (byte-optimize-predicate form))
form)) form))
(put 'concat 'byte-optimizer 'byte-optimize-concat) (put 'concat 'byte-optimizer 'byte-optimize-pure-func)
(defun byte-optimize-concat (form) (put 'symbol-name 'byte-optimizer 'byte-optimize-pure-func)
(put 'regexp-opt 'byte-optimizer 'byte-optimize-pure-func)
(put 'regexp-quote 'byte-optimizer 'byte-optimize-pure-func)
(defun byte-optimize-pure-func (form)
"Do constant folding for pure functions.
This assumes that the function will not have any side-effects and that
its return value depends solely on its arguments.
If the function can signal an error, this might change the semantics
of FORM by signalling the error at compile-time."
(let ((args (cdr form)) (let ((args (cdr form))
(constant t)) (constant t))
(while (and args constant) (while (and args constant)
@ -1181,28 +1187,28 @@
`(progn ,(cadr form) (setq ,(cadr var) ,@(cddr form)))) `(progn ,(cadr form) (setq ,(cadr var) ,@(cddr form))))
(t form)))) (t form))))
;;; enumerating those functions which need not be called if the returned ;; enumerating those functions which need not be called if the returned
;;; value is not used. That is, something like ;; value is not used. That is, something like
;;; (progn (list (something-with-side-effects) (yow)) ;; (progn (list (something-with-side-effects) (yow))
;;; (foo)) ;; (foo))
;;; may safely be turned into ;; may safely be turned into
;;; (progn (progn (something-with-side-effects) (yow)) ;; (progn (progn (something-with-side-effects) (yow))
;;; (foo)) ;; (foo))
;;; Further optimizations will turn (progn (list 1 2 3) 'foo) into 'foo. ;; Further optimizations will turn (progn (list 1 2 3) 'foo) into 'foo.
;;; Some of these functions have the side effect of allocating memory ;; Some of these functions have the side effect of allocating memory
;;; and it would be incorrect to replace two calls with one. ;; and it would be incorrect to replace two calls with one.
;;; But we don't try to do those kinds of optimizations, ;; But we don't try to do those kinds of optimizations,
;;; so it is safe to list such functions here. ;; so it is safe to list such functions here.
;;; Some of these functions return values that depend on environment ;; Some of these functions return values that depend on environment
;;; state, so that constant folding them would be wrong, ;; state, so that constant folding them would be wrong,
;;; but we don't do constant folding based on this list. ;; but we don't do constant folding based on this list.
;;; However, at present the only optimization we normally do ;; However, at present the only optimization we normally do
;;; is delete calls that need not occur, and we only do that ;; is delete calls that need not occur, and we only do that
;;; with the error-free functions. ;; with the error-free functions.
;;; I wonder if I missed any :-\) ;; I wonder if I missed any :-\)
(let ((side-effect-free-fns (let ((side-effect-free-fns
'(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan '(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan
assoc assq assoc assq
@ -1298,8 +1304,8 @@
(defconst byte-constref-ops (defconst byte-constref-ops
'(byte-constant byte-constant2 byte-varref byte-varset byte-varbind)) '(byte-constant byte-constant2 byte-varref byte-varset byte-varbind))
;;; This function extracts the bitfields from variable-length opcodes. ;; This function extracts the bitfields from variable-length opcodes.
;;; Originally defined in disass.el (which no longer uses it.) ;; Originally defined in disass.el (which no longer uses it.)
(defun disassemble-offset () (defun disassemble-offset ()
"Don't call this!" "Don't call this!"
@ -1336,11 +1342,11 @@
(aref bytes ptr)))) (aref bytes ptr))))
;;; This de-compiler is used for inline expansion of compiled functions, ;; This de-compiler is used for inline expansion of compiled functions,
;;; and by the disassembler. ;; and by the disassembler.
;;; ;;
;;; This list contains numbers, which are pc values, ;; This list contains numbers, which are pc values,
;;; before each instruction. ;; before each instruction.
(defun byte-decompile-bytecode (bytes constvec) (defun byte-decompile-bytecode (bytes constvec)
"Turns BYTECODE into lapcode, referring to CONSTVEC." "Turns BYTECODE into lapcode, referring to CONSTVEC."
(let ((byte-compile-constants nil) (let ((byte-compile-constants nil)
@ -1461,38 +1467,39 @@
byte-member byte-assq byte-quo byte-rem) byte-member byte-assq byte-quo byte-rem)
byte-compile-side-effect-and-error-free-ops)) byte-compile-side-effect-and-error-free-ops))
;;; This crock is because of the way DEFVAR_BOOL variables work. ;; This crock is because of the way DEFVAR_BOOL variables work.
;;; Consider the code ;; Consider the code
;;; ;;
;;; (defun foo (flag) ;; (defun foo (flag)
;;; (let ((old-pop-ups pop-up-windows) ;; (let ((old-pop-ups pop-up-windows)
;;; (pop-up-windows flag)) ;; (pop-up-windows flag))
;;; (cond ((not (eq pop-up-windows old-pop-ups)) ;; (cond ((not (eq pop-up-windows old-pop-ups))
;;; (setq old-pop-ups pop-up-windows) ;; (setq old-pop-ups pop-up-windows)
;;; ...)))) ;; ...))))
;;; ;;
;;; Uncompiled, old-pop-ups will always be set to nil or t, even if FLAG is ;; Uncompiled, old-pop-ups will always be set to nil or t, even if FLAG is
;;; something else. But if we optimize ;; something else. But if we optimize
;;; ;;
;;; varref flag ;; varref flag
;;; varbind pop-up-windows ;; varbind pop-up-windows
;;; varref pop-up-windows ;; varref pop-up-windows
;;; not ;; not
;;; to ;; to
;;; varref flag ;; varref flag
;;; dup ;; dup
;;; varbind pop-up-windows ;; varbind pop-up-windows
;;; not ;; not
;;; ;;
;;; we break the program, because it will appear that pop-up-windows and ;; we break the program, because it will appear that pop-up-windows and
;;; old-pop-ups are not EQ when really they are. So we have to know what ;; old-pop-ups are not EQ when really they are. So we have to know what
;;; the BOOL variables are, and not perform this optimization on them. ;; the BOOL variables are, and not perform this optimization on them.
;;; The variable `byte-boolean-vars' is now primitive and updated ;; The variable `byte-boolean-vars' is now primitive and updated
;;; automatically by DEFVAR_BOOL. ;; automatically by DEFVAR_BOOL.
(defun byte-optimize-lapcode (lap &optional for-effect) (defun byte-optimize-lapcode (lap &optional for-effect)
"Simple peephole optimizer. LAP is both modified and returned." "Simple peephole optimizer. LAP is both modified and returned.
If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
(let (lap0 (let (lap0
lap1 lap1
lap2 lap2