(require 'bytecomp)
(defun byte-compile-log-lap-1 (format &rest args)
(if (aref byte-code-vector 0)
(error "The old version of the disassembler is loaded. Reload new-bytecomp as well."))
(byte-compile-log-1
(apply 'format format
(let (c a)
(mapcar '(lambda (arg)
(if (not (consp arg))
(if (and (symbolp arg)
(string-match "^byte-" (symbol-name arg)))
(intern (substring (symbol-name arg) 5))
arg)
(if (integerp (setq c (car arg)))
(error "non-symbolic byte-op %s" c))
(if (eq c 'TAG)
(setq c arg)
(setq a (cond ((memq c byte-goto-ops)
(car (cdr (cdr arg))))
((memq c byte-constref-ops)
(car (cdr arg)))
(t (cdr arg))))
(setq c (symbol-name c))
(if (string-match "^byte-." c)
(setq c (intern (substring c 5)))))
(if (eq c 'constant) (setq c 'const))
(if (and (eq (cdr arg) 0)
(not (memq c '(unbind call const))))
c
(format "(%s %s)" c a))))
args)))))
(defmacro byte-compile-log-lap (format-string &rest args)
(list 'and
'(memq byte-optimize-log '(t byte))
(cons 'byte-compile-log-lap-1
(cons format-string args))))
(put 'inline 'byte-optimizer 'byte-optimize-inline-handler)
(defun byte-optimize-inline-handler (form)
"byte-optimize-handler for the `inline' special-form."
(cons 'progn
(mapcar
'(lambda (sexp)
(let ((fn (car-safe sexp)))
(if (and (symbolp fn)
(or (cdr (assq fn byte-compile-function-environment))
(and (fboundp fn)
(not (or (cdr (assq fn byte-compile-macro-environment))
(and (consp (setq fn (symbol-function fn)))
(eq (car fn) 'macro))
(subrp fn))))))
(byte-compile-inline-expand sexp)
sexp)))
(cdr form))))
(defun byte-inline-lapcode (lap)
(setq byte-compile-output (nconc (nreverse lap) byte-compile-output)))
(defun byte-compile-inline-expand (form)
(let* ((name (car form))
(fn (or (cdr (assq name byte-compile-function-environment))
(and (fboundp name) (symbol-function name)))))
(if (null fn)
(progn
(byte-compile-warn "attempt to inline %s before it was defined" name)
form)
(if (and (consp fn) (eq (car fn) 'autoload))
(progn
(load (nth 1 fn))
(setq fn (or (cdr (assq name byte-compile-function-environment))
(and (fboundp name) (symbol-function name))))))
(if (and (consp fn) (eq (car fn) 'autoload))
(error "file \"%s\" didn't define \"%s\"" (nth 1 fn) name))
(if (symbolp fn)
(byte-compile-inline-expand (cons fn (cdr form)))
(if (byte-code-function-p fn)
(let (string)
(fetch-bytecode fn)
(setq string (aref fn 1))
(if (fboundp 'string-as-unibyte)
(setq string (string-as-unibyte string)))
(cons (list 'lambda (aref fn 0)
(list 'byte-code string (aref fn 2) (aref fn 3)))
(cdr form)))
(if (eq (car-safe fn) 'lambda)
(cons fn (cdr form))
form))))))
(defun byte-compile-unfold-lambda (form &optional name)
(or name (setq name "anonymous lambda"))
(let ((lambda (car form))
(values (cdr form)))
(if (byte-code-function-p lambda)
(setq lambda (list 'lambda (aref lambda 0)
(list 'byte-code (aref lambda 1)
(aref lambda 2) (aref lambda 3)))))
(let ((arglist (nth 1 lambda))
(body (cdr (cdr lambda)))
optionalp restp
bindings)
(if (and (stringp (car body)) (cdr body))
(setq body (cdr body)))
(if (and (consp (car body)) (eq 'interactive (car (car body))))
(setq body (cdr body)))
(while arglist
(cond ((eq (car arglist) '&optional)
(if restp (error "&optional found after &rest in %s" name))
(if (null (cdr arglist))
(error "nothing after &optional in %s" name))
(setq optionalp t))
((eq (car arglist) '&rest)
(if (null (cdr arglist))
(error "nothing after &rest in %s" name))
(if (cdr (cdr arglist))
(error "multiple vars after &rest in %s" name))
(setq restp t))
(restp
(setq bindings (cons (list (car arglist)
(and values (cons 'list values)))
bindings)
values nil))
((and (not optionalp) (null values))
(byte-compile-warn "attempt to open-code %s with too few arguments" name)
(setq arglist nil values 'too-few))
(t
(setq bindings (cons (list (car arglist) (car values))
bindings)
values (cdr values))))
(setq arglist (cdr arglist)))
(if values
(progn
(or (eq values 'too-few)
(byte-compile-warn
"attempt to open-code %s with too many arguments" name))
form)
(setq body (mapcar 'byte-optimize-form body))
(let ((newform
(if bindings
(cons 'let (cons (nreverse bindings) body))
(cons 'progn body))))
(byte-compile-log " %s\t==>\t%s" form newform)
newform)))))
(defun byte-optimize-form-code-walker (form for-effect)
(let ((fn (car-safe form))
tmp)
(cond ((not (consp form))
(if (not (and for-effect
(or byte-compile-delete-errors
(not (symbolp form))
(eq form t))))
form))
((eq fn 'quote)
(if (cdr (cdr form))
(byte-compile-warn "malformed quote form: %s"
(prin1-to-string form)))
(and (nth 1 form)
(not for-effect)
form))
((or (byte-code-function-p fn)
(eq 'lambda (car-safe fn)))
(byte-compile-unfold-lambda form))
((memq fn '(let let*))
(cons fn
(cons
(mapcar '(lambda (binding)
(if (symbolp binding)
binding
(if (cdr (cdr binding))
(byte-compile-warn "malformed let binding: %s"
(prin1-to-string binding)))
(list (car binding)
(byte-optimize-form (nth 1 binding) nil))))
(nth 1 form))
(byte-optimize-body (cdr (cdr form)) for-effect))))
((eq fn 'cond)
(cons fn
(mapcar '(lambda (clause)
(if (consp clause)
(cons
(byte-optimize-form (car clause) nil)
(byte-optimize-body (cdr clause) for-effect))
(byte-compile-warn "malformed cond form: %s"
(prin1-to-string clause))
clause))
(cdr form))))
((eq fn 'progn)
(if (cdr (cdr form))
(progn
(setq tmp (byte-optimize-body (cdr form) for-effect))
(if (cdr tmp) (cons 'progn tmp) (car tmp)))
(byte-optimize-form (nth 1 form) for-effect)))
((eq fn 'prog1)
(if (cdr (cdr form))
(cons 'prog1
(cons (byte-optimize-form (nth 1 form) for-effect)
(byte-optimize-body (cdr (cdr form)) t)))
(byte-optimize-form (nth 1 form) for-effect)))
((eq fn 'prog2)
(cons 'prog2
(cons (byte-optimize-form (nth 1 form) t)
(cons (byte-optimize-form (nth 2 form) for-effect)
(byte-optimize-body (cdr (cdr (cdr form))) t)))))
((memq fn '(save-excursion save-restriction save-current-buffer))
(cons fn (byte-optimize-body (cdr form) for-effect)))
((eq fn 'with-output-to-temp-buffer)
(cons fn
(cons
(byte-optimize-form (nth 1 form) nil)
(byte-optimize-body (cdr (cdr form)) for-effect))))
((eq fn 'if)
(cons fn
(cons (byte-optimize-form (nth 1 form) nil)
(cons
(byte-optimize-form (nth 2 form) for-effect)
(byte-optimize-body (nthcdr 3 form) for-effect)))))
((memq fn '(and or)) (if for-effect
(let ((backwards (reverse (cdr form))))
(while (and backwards
(null (setcar backwards
(byte-optimize-form (car backwards)
for-effect))))
(setq backwards (cdr backwards)))
(if (and (cdr form) (null backwards))
(byte-compile-log
" all subforms of %s called for effect; deleted" form))
(and backwards
(cons fn (nreverse backwards))))
(cons fn (mapcar 'byte-optimize-form (cdr form)))))
((eq fn 'interactive)
(byte-compile-warn "misplaced interactive spec: %s"
(prin1-to-string form))
nil)
((memq fn '(defun defmacro function
condition-case save-window-excursion))
form)
((eq fn 'unwind-protect)
(cons fn
(cons (byte-optimize-form (nth 1 form) for-effect)
(cdr (cdr form)))))
((eq fn 'catch)
(cons fn
(cons (byte-optimize-form (nth 1 form) nil)
(cdr (cdr form)))))
((not (eq form
(setq form (macroexpand form
byte-compile-macro-environment))))
(byte-optimize-form form for-effect))
((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)) (byte-compile-warn "%s is a malformed function"
(prin1-to-string fn)))
form)
((and for-effect (setq tmp (get fn 'side-effect-free))
(or byte-compile-delete-errors
(eq tmp 'error-free)
(progn
(byte-compile-warn "%s called for effect"
(prin1-to-string form))
nil)))
(byte-compile-log " %s called for effect; deleted" fn)
(byte-optimize-form
(cons 'progn (append (cdr form) '(nil))) t))
(t
(cons fn (mapcar 'byte-optimize-form (cdr form)))))))
(defun byte-optimize-form (form &optional for-effect)
"The source-level pass of the optimizer."
(setq form (byte-optimize-form-code-walker form for-effect))
(let (opt new)
(if (and (consp form)
(symbolp (car form))
(or (and for-effect
(setq opt (get (car form) 'byte-for-effect-optimizer)))
(setq opt (get (car form) 'byte-optimizer)))
(not (eq form (setq new (funcall opt form)))))
(progn
(byte-compile-log " %s\t==>\t%s" form new)
(setq new (byte-optimize-form new for-effect))
new)
form)))
(defun byte-optimize-body (forms all-for-effect)
(let ((rest forms)
(result nil)
fe new)
(while rest
(setq fe (or all-for-effect (cdr rest)))
(setq new (and (car rest) (byte-optimize-form (car rest) fe)))
(if (or new (not fe))
(setq result (cons new result)))
(setq rest (cdr rest)))
(nreverse result)))
(defmacro byte-compile-trueconstp (form)
(` (cond ((consp (, form)) (eq (car (, form)) 'quote))
((not (symbolp (, form))))
((eq (, form) t)))))
(defun byte-optimize-associative-math (form)
(let ((args nil)
(constants nil)
(rest (cdr form)))
(while rest
(if (numberp (car rest))
(setq constants (cons (car rest) constants))
(setq args (cons (car rest) args)))
(setq rest (cdr rest)))
(if (cdr constants)
(if args
(list (car form)
(apply (car form) constants)
(if (cdr args)
(cons (car form) (nreverse args))
(car args)))
(apply (car form) constants))
form)))
(defun byte-optimize-nonassociative-math (form)
(if (or (not (numberp (car (cdr form))))
(not (numberp (car (cdr (cdr form))))))
form
(let ((constant (car (cdr form)))
(rest (cdr (cdr form))))
(while (numberp (car rest))
(setq constant (funcall (car form) constant (car rest))
rest (cdr rest)))
(if rest
(cons (car form) (cons constant rest))
constant))))
(defun byte-optimize-approx-equal (x y)
(<= (* (abs (- x y)) 100) (abs (+ x y))))
(defun byte-optimize-delay-constants-math (form start fun)
(let ((rest (nthcdr (1- start) form))
(orig form)
(overflow (memq fun '(+ *))))
(while (cdr (setq rest (cdr rest)))
(if (integerp (car rest))
(let (constants)
(setq form (copy-sequence form)
rest (nthcdr (1- start) form))
(while (setq rest (cdr rest))
(cond ((integerp (car rest))
(setq constants (cons (car rest) constants))
(setcar rest nil))))
(if (and overflow
(not (byte-optimize-approx-equal
(apply fun (mapcar 'float constants))
(float (apply fun constants)))))
(setq form orig)
(setq form (nconc (delq nil form)
(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))))
(cond ((null (cdr form))
(condition-case ()
(eval form)
(error form)))
((null (cddr form))
(if (numberp (nth 1 form))
(nth 1 form)
form))
((and (null (nthcdr 3 form))
(or (memq (nth 1 form) '(1 -1))
(memq (nth 2 form) '(1 -1))))
(let ((integer
(if (memq (nth 1 form) '(1 -1))
(nth 1 form)
(nth 2 form)))
(other
(if (memq (nth 1 form) '(1 -1))
(nth 2 form)
(nth 1 form))))
(list (if (eq integer 1) '1+ '1-)
other)))
(t form)))
(defun byte-optimize-minus (form)
(setq form (byte-optimize-delay-constants-math form 2 '+))
(let ((last (car (reverse (nthcdr 3 form)))))
(cond ((eq 0 last)
(setq form (copy-sequence form))
(setcdr (cdr (cdr form)) (delq 0 (nthcdr 3 form))))
((equal (nthcdr 2 form) '(1))
(setq form (list '1- (nth 1 form))))
((equal (nthcdr 2 form) '(-1))
(setq form (list '1+ (nth 1 form))))
((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))))))))
(byte-optimize-predicate
(if (and (null (cdr (cdr (cdr form))))
(eq (nth 1 form) 0)) (cons (car form) (cdr (cdr form)))
form))
)
(defun byte-optimize-multiply (form)
(setq form (byte-optimize-delay-constants-math form 1 '*))
(cond ((null (cdr form)) 1)
((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))))))
(defsubst byte-compile-butlast (form)
(nreverse (cdr (reverse form))))
(defun byte-optimize-divide (form)
(setq form (byte-optimize-delay-constants-math form 2 '*))
(let ((last (car (reverse (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 (byte-compile-butlast form)))
((numberp (nth 1 form))
(setq form (cons (car form)
(cons (/ (nth 1 form) last)
(byte-compile-butlast (cdr (cdr form)))))
last nil))))
(cond
((eq (nth 1 form) 0)
(append '(progn) (cdr (cdr form)) '(0)))
((eq last -1)
(list '- (if (nthcdr 3 form)
(byte-compile-butlast form)
(nth 1 form))))
(form))))
(defun byte-optimize-logmumble (form)
(setq form (byte-optimize-delay-constants-math form 1 (car form)))
(byte-optimize-predicate
(cond ((memq 0 form)
(setq form (if (eq (car form) 'logand)
(cons 'progn (cdr form))
(delq 0 (copy-sequence form)))))
((and (eq (car-safe form) 'logior)
(memq -1 form))
(cons 'progn (cdr form)))
(form))))
(defun byte-optimize-binary-predicate (form)
(if (byte-compile-constp (nth 1 form))
(if (byte-compile-constp (nth 2 form))
(condition-case ()
(list 'quote (eval form))
(error form))
(list (car form) (nth 2 form) (nth 1 form)))
form))
(defun byte-optimize-predicate (form)
(let ((ok t)
(rest (cdr form)))
(while (and rest ok)
(setq ok (byte-compile-constp (car rest))
rest (cdr rest)))
(if ok
(condition-case ()
(list 'quote (eval form))
(error form))
form)))
(defun byte-optimize-identity (form)
(if (and (cdr form) (null (cdr (cdr form))))
(nth 1 form)
(byte-compile-warn "identity called with %d arg%s, but requires 1"
(length (cdr form))
(if (= 1 (length (cdr form))) "" "s"))
form))
(put 'identity 'byte-optimizer 'byte-optimize-identity)
(put '+ 'byte-optimizer 'byte-optimize-plus)
(put '* 'byte-optimizer 'byte-optimize-multiply)
(put '- 'byte-optimizer 'byte-optimize-minus)
(put '/ 'byte-optimizer 'byte-optimize-divide)
(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)
(put '1+ 'byte-optimizer 'byte-optimize-predicate)
(put '1- 'byte-optimizer 'byte-optimize-predicate)
(put 'not 'byte-optimizer 'byte-optimize-predicate)
(put 'null 'byte-optimizer 'byte-optimize-predicate)
(put 'memq 'byte-optimizer 'byte-optimize-predicate)
(put 'consp 'byte-optimizer 'byte-optimize-predicate)
(put 'listp 'byte-optimizer 'byte-optimize-predicate)
(put 'symbolp 'byte-optimizer 'byte-optimize-predicate)
(put 'stringp 'byte-optimizer 'byte-optimize-predicate)
(put 'string< 'byte-optimizer 'byte-optimize-predicate)
(put 'string-lessp 'byte-optimizer 'byte-optimize-predicate)
(put 'logand 'byte-optimizer 'byte-optimize-logmumble)
(put 'logior 'byte-optimizer 'byte-optimize-logmumble)
(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-safe 'byte-optimizer 'byte-optimize-predicate)
(put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate)
(put 'quote 'byte-optimizer 'byte-optimize-quote)
(defun byte-optimize-quote (form)
(if (or (consp (nth 1 form))
(and (symbolp (nth 1 form))
(not (memq (nth 1 form) '(nil t)))))
form
(nth 1 form)))
(defun byte-optimize-zerop (form)
(cond ((numberp (nth 1 form))
(eval form))
(byte-compile-delete-errors
(list '= (nth 1 form) 0))
(form)))
(put 'zerop 'byte-optimizer 'byte-optimize-zerop)
(defun byte-optimize-and (form)
(cond ((null (cdr form)))
((memq nil form)
(list 'progn
(byte-optimize-and
(prog1 (setq form (copy-sequence form))
(while (nth 1 form)
(setq form (cdr form)))
(setcdr form nil)))
nil))
((null (cdr (cdr form)))
(nth 1 form))
((byte-optimize-predicate form))))
(defun byte-optimize-or (form)
(if (memq nil form)
(setq form (delq nil (copy-sequence form))))
(let ((rest form))
(while (cdr (setq rest (cdr rest)))
(if (byte-compile-trueconstp (car rest))
(setq form (copy-sequence form)
rest (setcdr (memq (car rest) form) nil))))
(if (cdr (cdr form))
(byte-optimize-predicate form)
(nth 1 form))))
(defun byte-optimize-cond (form)
(let (rest)
(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)))))
(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))
(defun byte-optimize-if (form)
(let ((clause (nth 1 form)))
(cond ((byte-compile-trueconstp clause)
(nth 2 form))
((null clause)
(if (nthcdr 4 form)
(cons 'progn (nthcdr 3 form))
(nth 3 form)))
((nth 2 form)
(if (equal '(nil) (nthcdr 3 form))
(list 'if clause (nth 2 form))
form))
((or (nth 3 form) (nthcdr 4 form))
(list 'if
(if (and (consp clause) (memq (car clause) '(not null))
(= (length clause) 2)) (nth 1 clause)
(list 'not clause))
(if (nthcdr 4 form)
(cons 'progn (nthcdr 3 form))
(nth 3 form))))
(t
(list 'progn clause nil)))))
(defun byte-optimize-while (form)
(if (nth 1 form)
form))
(put 'and 'byte-optimizer 'byte-optimize-and)
(put 'or 'byte-optimizer 'byte-optimize-or)
(put 'cond 'byte-optimizer 'byte-optimize-cond)
(put 'if 'byte-optimizer 'byte-optimize-if)
(put 'while 'byte-optimizer 'byte-optimize-while)
(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)
(let ((fn (nth 1 form)))
(if (memq (car-safe fn) '(quote function))
(cons (nth 1 fn) (cdr (cdr form)))
form)))
(defun byte-optimize-apply (form)
(let ((fn (nth 1 form))
(last (nth (1- (length form)) form))) (or (if (or (null last)
(eq (car-safe last) 'quote))
(if (listp (nth 1 last))
(let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
(nconc (list 'funcall fn) butlast
(mapcar '(lambda (x) (list 'quote x)) (nth 1 last))))
(byte-compile-warn
"last arg to apply can't be a literal atom: %s"
(prin1-to-string last))
nil))
form)))
(put 'funcall 'byte-optimizer 'byte-optimize-funcall)
(put 'apply 'byte-optimizer 'byte-optimize-apply)
(put 'let 'byte-optimizer 'byte-optimize-letX)
(put 'let* 'byte-optimizer 'byte-optimize-letX)
(defun byte-optimize-letX (form)
(cond ((null (nth 1 form))
(cons 'progn (cdr (cdr form))))
((or (nth 2 form) (nthcdr 3 form))
form)
((eq (car form) 'let)
(append '(progn) (mapcar 'car-safe (mapcar 'cdr-safe (nth 1 form)))
'(nil)))
(t
(let ((binds (reverse (nth 1 form))))
(list 'let* (reverse (cdr binds)) (nth 1 (car binds)) nil)))))
(put 'nth 'byte-optimizer 'byte-optimize-nth)
(defun byte-optimize-nth (form)
(if (and (= (safe-length form) 3) (memq (nth 1 form) '(0 1)))
(list 'car (if (zerop (nth 1 form))
(nth 2 form)
(list 'cdr (nth 2 form))))
(byte-optimize-predicate form)))
(put 'nthcdr 'byte-optimizer 'byte-optimize-nthcdr)
(defun byte-optimize-nthcdr (form)
(if (and (= (safe-length form) 3) (not (memq (nth 1 form) '(0 1 2))))
(byte-optimize-predicate form)
(let ((count (nth 1 form)))
(setq form (nth 2 form))
(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)))
(let ((side-effect-free-fns
'(% * + - / /= 1+ 1- < <= = > >= abs acos append aref ash asin atan
assoc assq
boundp buffer-file-name buffer-local-variables buffer-modified-p
buffer-substring
capitalize car-less-than-car car cdr ceiling concat coordinates-in-window-p
copy-marker cos count-lines
default-boundp default-value documentation downcase
elt exp expt fboundp featurep
file-directory-p file-exists-p file-locked-p file-name-absolute-p
file-newer-than-file-p file-readable-p file-symlink-p file-writable-p
float floor format
get get-buffer get-buffer-window getenv get-file-buffer
int-to-string
length log log10 logand logb logior lognot logxor lsh
marker-buffer max member memq min mod
next-window nth nthcdr number-to-string
parse-colon-path previous-window
radians-to-degrees rassq regexp-quote reverse round
sin sqrt string< string= string-equal string-lessp string-to-char
string-to-int string-to-number substring symbol-plist
tan upcase user-variable-p vconcat
window-buffer window-dedicated-p window-edges window-height
window-hscroll window-minibuffer-p window-width
zerop))
(side-effect-and-error-free-fns
'(arrayp atom
bobp bolp buffer-end buffer-list buffer-size buffer-string bufferp
car-safe case-table-p cdr-safe char-or-string-p commandp cons consp
current-buffer
dot dot-marker eobp eolp eq eql equal eventp floatp framep
get-largest-window get-lru-window
identity ignore integerp integer-or-marker-p interactive-p
invocation-directory invocation-name
keymapp list listp
make-marker mark mark-marker markerp memory-limit minibuffer-window
mouse-movement-p
natnump nlistp not null number-or-marker-p numberp
one-window-p overlayp
point point-marker point-min point-max processp
selected-window sequencep stringp subrp symbolp syntax-table-p
user-full-name user-login-name user-original-login-name
user-real-login-name user-real-uid user-uid
vector vectorp
window-configuration-p window-live-p windowp)))
(while side-effect-free-fns
(put (car side-effect-free-fns) 'side-effect-free t)
(setq side-effect-free-fns (cdr side-effect-free-fns)))
(while side-effect-and-error-free-fns
(put (car side-effect-and-error-free-fns) 'side-effect-free 'error-free)
(setq side-effect-and-error-free-fns (cdr side-effect-and-error-free-fns)))
nil)
(defun byte-compile-splice-in-already-compiled-code (form)
(if (not (memq byte-optimize '(t lap)))
(byte-compile-normal-call form)
(byte-inline-lapcode
(byte-decompile-bytecode-1 (nth 1 form) (nth 2 form) t))
(setq byte-compile-maxdepth (max (+ byte-compile-depth (nth 3 form))
byte-compile-maxdepth))
(setq byte-compile-depth (1+ byte-compile-depth))))
(put 'byte-code 'byte-compile 'byte-compile-splice-in-already-compiled-code)
(defconst byte-constref-ops
'(byte-constant byte-constant2 byte-varref byte-varset byte-varbind))
(defun disassemble-offset ()
"Don't call this!"
(defvar op)
(defvar ptr)
(defvar bytes)
(cond ((< op byte-nth)
(let ((tem (logand op 7)))
(setq op (logand op 248))
(cond ((eq tem 6)
(setq ptr (1+ ptr)) (aref bytes ptr))
((eq tem 7)
(setq ptr (1+ ptr)) (+ (aref bytes ptr)
(progn (setq ptr (1+ ptr))
(lsh (aref bytes ptr) 8))))
(t tem)))) ((>= op byte-constant)
(prog1 (- op byte-constant) (setq op byte-constant)))
((and (>= op byte-constant2)
(<= op byte-goto-if-not-nil-else-pop))
(setq ptr (1+ ptr)) (+ (aref bytes ptr)
(progn (setq ptr (1+ ptr))
(lsh (aref bytes ptr) 8))))
((and (>= op byte-listN)
(<= op byte-insertN))
(setq ptr (1+ ptr)) (aref bytes ptr))))
(defun byte-decompile-bytecode (bytes constvec)
"Turns BYTECODE into lapcode, referring to CONSTVEC."
(let ((byte-compile-constants nil)
(byte-compile-variables nil)
(byte-compile-tag-number 0))
(byte-decompile-bytecode-1 bytes constvec)))
(defun byte-decompile-bytecode-1 (bytes constvec &optional make-spliceable)
(let ((length (length bytes))
(ptr 0) optr tag tags op offset
lap tmp
endtag
(retcount 0))
(while (not (= ptr length))
(or make-spliceable
(setq lap (cons ptr lap)))
(setq op (aref bytes ptr)
optr ptr
offset (disassemble-offset)) (setq op (aref byte-code-vector op))
(cond ((memq op byte-goto-ops)
(setq offset
(cdr (or (assq offset tags)
(car (setq tags
(cons (cons offset
(byte-compile-make-tag))
tags)))))))
((cond ((eq op 'byte-constant2) (setq op 'byte-constant) t)
((memq op byte-constref-ops)))
(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)
(car (setq byte-compile-variables
(cons (list tmp)
byte-compile-variables)))))))
((and make-spliceable
(eq op 'byte-return))
(if (= ptr (1- length))
(setq op nil)
(setq offset (or endtag (setq endtag (byte-compile-make-tag)))
op 'byte-goto))))
(setq lap (cons (cons optr (cons op (or offset 0)))
lap))
(setq ptr (1+ ptr)))
(let ((rest lap))
(while rest
(cond ((numberp (car rest)))
((setq tmp (assq (car (car rest)) tags))
(setcdr rest (cons (cons nil (cdr tmp))
(cdr rest)))
(setq tags (delq tmp tags))
(setq rest (cdr rest))))
(setq rest (cdr rest))))
(if tags (error "optimizer error: missed tags %s" tags))
(if (null (car (cdr (car lap))))
(setq lap (cdr lap)))
(if endtag
(setq lap (cons (cons nil endtag) lap)))
(mapcar (function (lambda (elt)
(if (numberp elt)
elt
(cdr elt))))
(nreverse lap))))
(defconst byte-tagref-ops (cons 'TAG byte-goto-ops))
(defconst byte-conditional-ops
'(byte-goto-if-nil byte-goto-if-not-nil byte-goto-if-nil-else-pop
byte-goto-if-not-nil-else-pop))
(defconst byte-after-unbind-ops
'(byte-constant byte-dup
byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp
byte-eq byte-not
byte-cons byte-list1 byte-list2 byte-interactive-p)
"Byte-codes that can be moved past an unbind.")
(defconst byte-compile-side-effect-and-error-free-ops
'(byte-constant byte-dup byte-symbolp byte-consp byte-stringp byte-listp
byte-integerp byte-numberp byte-eq byte-equal byte-not byte-car-safe
byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max
byte-point-min byte-following-char byte-preceding-char
byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp
byte-current-buffer byte-interactive-p))
(defconst byte-compile-side-effect-free-ops
(nconc
'(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref
byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1
byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate
byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax
byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt
byte-member byte-assq byte-quo byte-rem)
byte-compile-side-effect-and-error-free-ops))
(defconst byte-boolean-vars
'(abbrev-all-caps abbrevs-changed byte-debug-flag byte-metering-on
cannot-suspend check-markers-debug-flag completion-auto-help
completion-ignore-case cursor-in-echo-area debug-on-next-call
debug-on-quit delete-exited-processes enable-recursive-minibuffers
garbage-collection-messages highlight-nonselected-windows
indent-tabs-mode inherit-process-coding-system inhibit-eol-conversion
inhibit-local-menu-bar-menus insert-default-directory inverse-video
keyword-symbols-constant-flag load-convert-to-unibyte
load-force-doc-strings load-in-progress menu-prompting
minibuffer-allow-text-properties minibuffer-auto-raise
mode-line-inverse-video multiple-frames no-redraw-on-reenter
noninteractive parse-sexp-ignore-comments parse-sexp-lookup-properties
pop-up-frames pop-up-windows print-escape-multibyte
print-escape-newlines
print-escape-nonascii print-quoted scroll-preserve-screen-position
system-uses-terminfo truncate-partial-width-windows
unibyte-display-via-language-environment use-dialog-box
visible-bell vms-stmlf-recfm words-include-escapes)
"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."
(let (lap0 off0
lap1 off1
lap2 off2
(keep-going 'first-time)
(add-depth 0)
rest tmp tmp2 tmp3
(side-effect-free (if byte-compile-delete-errors
byte-compile-side-effect-free-ops
byte-compile-side-effect-and-error-free-ops)))
(while keep-going
(or (eq keep-going 'first-time)
(byte-compile-log-lap " ---- next pass"))
(setq rest lap
keep-going nil)
(while rest
(setq lap0 (car rest)
lap1 (nth 1 rest)
lap2 (nth 2 rest))
(cond ((and (eq 'byte-discard (car lap1))
(memq (car lap0) side-effect-free))
(setq keep-going t)
(setq tmp (aref byte-stack+-info (symbol-value (car lap0))))
(setq rest (cdr rest))
(cond ((= tmp 1)
(byte-compile-log-lap
" %s discard\t-->\t<deleted>" lap0)
(setq lap (delq lap0 (delq lap1 lap))))
((= tmp 0)
(byte-compile-log-lap
" %s discard\t-->\t<deleted> discard" lap0)
(setq lap (delq lap0 lap)))
((= tmp -1)
(byte-compile-log-lap
" %s discard\t-->\tdiscard discard" lap0)
(setcar lap0 'byte-discard)
(setcdr lap0 0))
((error "Optimizer error: too much on the stack"))))
((and (memq (car lap0) byte-goto-ops)
(eq (cdr lap0) lap1))
(cond ((eq (car lap0) 'byte-goto)
(setq lap (delq lap0 lap))
(setq tmp "<deleted>"))
((memq (car lap0) byte-goto-always-pop-ops)
(setcar lap0 (setq tmp 'byte-discard))
(setcdr lap0 0))
((error "Depth conflict at tag %d" (nth 2 lap0))))
(and (memq byte-optimize-log '(t byte))
(byte-compile-log " (goto %s) %s:\t-->\t%s %s:"
(nth 1 lap1) (nth 1 lap1)
tmp (nth 1 lap1)))
(setq keep-going t))
((and (eq 'byte-varref (car lap2))
(eq (cdr lap1) (cdr lap2))
(memq (car lap1) '(byte-varset byte-varbind)))
(if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
(not (eq (car lap0) 'byte-constant)))
nil
(setq keep-going t)
(if (memq (car lap0) '(byte-constant byte-dup))
(progn
(setq tmp (if (or (not tmp)
(memq (car (cdr lap0)) '(nil t)))
(cdr lap0)
(byte-compile-get-constant t)))
(byte-compile-log-lap " %s %s %s\t-->\t%s %s %s"
lap0 lap1 lap2 lap0 lap1
(cons (car lap0) tmp))
(setcar lap2 (car lap0))
(setcdr lap2 tmp))
(byte-compile-log-lap " %s %s\t-->\tdup %s" lap1 lap2 lap1)
(setcar lap2 (car lap1))
(setcar lap1 'byte-dup)
(setcdr lap1 0)
(setq add-depth 1))))
((and (eq 'byte-dup (car lap0))
(eq 'byte-discard (car lap2))
(memq (car lap1) '(byte-varset byte-varbind)))
(byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
(setq keep-going t
rest (cdr rest))
(setq lap (delq lap0 (delq lap2 lap))))
((and (eq 'byte-not (car lap0))
(or (eq 'byte-goto-if-nil (car lap1))
(eq 'byte-goto-if-not-nil (car lap1))))
(byte-compile-log-lap " not %s\t-->\t%s"
lap1
(cons
(if (eq (car lap1) 'byte-goto-if-nil)
'byte-goto-if-not-nil
'byte-goto-if-nil)
(cdr lap1)))
(setcar lap1 (if (eq (car lap1) 'byte-goto-if-nil)
'byte-goto-if-not-nil
'byte-goto-if-nil))
(setq lap (delq lap0 lap))
(setq keep-going t))
((and (or (eq 'byte-goto-if-nil (car lap0))
(eq 'byte-goto-if-not-nil (car lap0))) (eq 'byte-goto (car lap1)) (eq (cdr lap0) lap2)) (let ((inverse (if (eq 'byte-goto-if-nil (car lap0))
'byte-goto-if-not-nil 'byte-goto-if-nil)))
(byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
lap0 lap1 lap2
(cons inverse (cdr lap1)) lap2)
(setq lap (delq lap0 lap))
(setcar lap1 inverse)
(setq keep-going t)))
((and (eq 'byte-constant (car lap0))
(memq (car lap1) byte-conditional-ops))
(cond ((if (or (eq (car lap1) 'byte-goto-if-nil)
(eq (car lap1) 'byte-goto-if-nil-else-pop))
(car (cdr lap0))
(not (car (cdr lap0))))
(byte-compile-log-lap " %s %s\t-->\t<deleted>"
lap0 lap1)
(setq rest (cdr rest)
lap (delq lap0 (delq lap1 lap))))
(t
(if (memq (car lap1) byte-goto-always-pop-ops)
(progn
(byte-compile-log-lap " %s %s\t-->\t%s"
lap0 lap1 (cons 'byte-goto (cdr lap1)))
(setq lap (delq lap0 lap)))
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
(cons 'byte-goto (cdr lap1))))
(setcar lap1 'byte-goto)))
(setq keep-going t))
((and (eq 'byte-varref (car lap0))
(progn
(setq tmp (cdr rest))
(while (eq (car (car tmp)) 'byte-dup)
(setq tmp (cdr tmp)))
t)
(eq (cdr lap0) (cdr (car tmp)))
(eq 'byte-varref (car (car tmp))))
(if (memq byte-optimize-log '(t byte))
(let ((str ""))
(setq tmp2 (cdr rest))
(while (not (eq tmp tmp2))
(setq tmp2 (cdr tmp2)
str (concat str " dup")))
(byte-compile-log-lap " %s%s %s\t-->\t%s%s dup"
lap0 str lap0 lap0 str)))
(setq keep-going t)
(setcar (car tmp) 'byte-dup)
(setcdr (car tmp) 0)
(setq rest tmp))
((and (eq (car lap0) 'TAG)
(eq (car lap1) 'TAG))
(and (memq byte-optimize-log '(t byte))
(byte-compile-log " adjacent tags %d and %d merged"
(nth 1 lap1) (nth 1 lap0)))
(setq tmp3 lap)
(while (setq tmp2 (rassq lap0 tmp3))
(setcdr tmp2 lap1)
(setq tmp3 (cdr (memq tmp2 tmp3))))
(setq lap (delq lap0 lap)
keep-going t))
((and (eq 'TAG (car lap0))
(not (rassq lap0 lap)))
(and (memq byte-optimize-log '(t byte))
(byte-compile-log " unused tag %d removed" (nth 1 lap0)))
(setq lap (delq lap0 lap)
keep-going t))
((and (memq (car lap0) '(byte-goto byte-return))
(not (memq (car lap1) '(TAG nil))))
(setq tmp rest)
(let ((i 0)
(opt-p (memq byte-optimize-log '(t lap)))
str deleted)
(while (and (setq tmp (cdr tmp))
(not (eq 'TAG (car (car tmp)))))
(if opt-p (setq deleted (cons (car tmp) deleted)
str (concat str " %s")
i (1+ i))))
(if opt-p
(let ((tagstr
(if (eq 'TAG (car (car tmp)))
(format "%d:" (car (cdr (car tmp))))
(or (car tmp) ""))))
(if (< i 6)
(apply 'byte-compile-log-lap-1
(concat " %s" str
" %s\t-->\t%s <deleted> %s")
lap0
(nconc (nreverse deleted)
(list tagstr lap0 tagstr)))
(byte-compile-log-lap
" %s <%d unreachable op%s> %s\t-->\t%s <deleted> %s"
lap0 i (if (= i 1) "" "s")
tagstr lap0 tagstr))))
(rplacd rest tmp))
(setq keep-going t))
((and (eq 'byte-unbind (car lap1))
(memq (car lap0) byte-after-unbind-ops))
(byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
(setcar rest lap1)
(setcar (cdr rest) lap0)
(setq keep-going t))
((and (eq 'byte-unbind (car lap1))
(memq (car lap0) '(byte-varbind byte-save-excursion
byte-save-restriction))
(< 0 (cdr lap1)))
(if (zerop (setcdr lap1 (1- (cdr lap1))))
(delq lap1 rest))
(if (eq (car lap0) 'byte-varbind)
(setcar rest (cons 'byte-discard 0))
(setq lap (delq lap0 lap)))
(byte-compile-log-lap " %s %s\t-->\t%s %s"
lap0 (cons (car lap1) (1+ (cdr lap1)))
(if (eq (car lap0) 'byte-varbind)
(car rest)
(car (cdr rest)))
(if (and (/= 0 (cdr lap1))
(eq (car lap0) 'byte-varbind))
(car (cdr rest))
""))
(setq keep-going t))
((and (memq (car lap0) byte-goto-ops)
(memq (car (setq tmp (nth 1 (memq (cdr lap0) lap))))
'(byte-goto byte-return)))
(cond ((and (not (eq tmp lap0))
(or (eq (car lap0) 'byte-goto)
(eq (car tmp) 'byte-goto)))
(byte-compile-log-lap " %s [%s]\t-->\t%s"
(car lap0) tmp tmp)
(if (eq (car tmp) 'byte-return)
(setcar lap0 'byte-return))
(setcdr lap0 (cdr tmp))
(setq keep-going t))))
((and (memq (car lap0) '(byte-goto-if-nil-else-pop
byte-goto-if-not-nil-else-pop))
(memq (car (car (setq tmp (cdr (memq (cdr lap0) lap)))))
(eval-when-compile
(cons 'byte-discard byte-conditional-ops)))
(not (eq lap0 (car tmp))))
(setq tmp2 (car tmp))
(setq tmp3 (assq (car lap0) '((byte-goto-if-nil-else-pop
byte-goto-if-nil)
(byte-goto-if-not-nil-else-pop
byte-goto-if-not-nil))))
(if (memq (car tmp2) tmp3)
(progn (setcar lap0 (car tmp2))
(setcdr lap0 (cdr tmp2))
(byte-compile-log-lap " %s-else-pop [%s]\t-->\t%s"
(car lap0) tmp2 lap0))
(or (eq 'TAG (car (nth 1 tmp)))
(setcdr tmp (cons (byte-compile-make-tag)
(cdr tmp))))
(byte-compile-log-lap " %s [%s]\t-->\t%s <skip>"
(car lap0) tmp2 (nth 1 tmp3))
(setcar lap0 (nth 1 tmp3))
(setcdr lap0 (nth 1 tmp)))
(setq keep-going t))
((and (eq (car lap0) 'byte-constant)
(eq (car lap1) 'byte-goto)
(memq (car (car (setq tmp (cdr (memq (cdr lap1) lap)))))
(eval-when-compile
(cons 'byte-discard byte-conditional-ops)))
(not (eq lap1 (car tmp))))
(setq tmp2 (car tmp))
(cond ((memq (car tmp2)
(if (null (car (cdr lap0)))
'(byte-goto-if-nil byte-goto-if-nil-else-pop)
'(byte-goto-if-not-nil
byte-goto-if-not-nil-else-pop)))
(byte-compile-log-lap " %s goto [%s]\t-->\t%s %s"
lap0 tmp2 lap0 tmp2)
(setcar lap1 (car tmp2))
(setcdr lap1 (cdr tmp2))
(setq rest (cons nil rest)))
(t
(byte-compile-log-lap
" %s goto [%s]\t-->\t<deleted> goto <skip>"
lap0 tmp2)
(or (eq 'TAG (car (nth 1 tmp)))
(setcdr tmp (cons (byte-compile-make-tag)
(cdr tmp))))
(setcdr lap1 (car (cdr tmp)))
(setq lap (delq lap0 lap))))
(setq keep-going t))
((and (eq (car lap1) 'byte-varset)
(eq (car lap2) 'byte-goto)
(not (memq (cdr lap2) rest)) (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
'byte-varref)
(eq (cdr (car tmp)) (cdr lap1))
(not (memq (car (cdr lap1)) byte-boolean-vars)))
(let ((newtag (byte-compile-make-tag)))
(byte-compile-log-lap
" %s: %s ... %s %s\t-->\t%s: %s %s: ... %s %s %s"
(nth 1 (cdr lap2)) (car tmp)
lap1 lap2
(nth 1 (cdr lap2)) (car tmp)
(nth 1 newtag) 'byte-dup lap1
(cons 'byte-goto newtag)
)
(setcdr rest (cons (cons 'byte-dup 0) (cdr rest)))
(setcdr tmp (cons (setcdr lap2 newtag) (cdr tmp))))
(setq add-depth 1)
(setq keep-going t))
((and (eq (car lap0) 'byte-goto)
(eq (car lap1) 'TAG)
(eq lap1
(cdr (car (setq tmp (cdr (memq (cdr lap0) lap))))))
(memq (car (car tmp))
'(byte-goto byte-goto-if-nil byte-goto-if-not-nil
byte-goto-if-nil-else-pop)))
(let ((newtag (byte-compile-make-tag)))
(byte-compile-log-lap
"%s %s: ... %s: %s\t-->\t%s ... %s:"
lap0 (nth 1 lap1) (nth 1 (cdr lap0)) (car tmp)
(cons (cdr (assq (car (car tmp))
'((byte-goto-if-nil . byte-goto-if-not-nil)
(byte-goto-if-not-nil . byte-goto-if-nil)
(byte-goto-if-nil-else-pop .
byte-goto-if-not-nil-else-pop)
(byte-goto-if-not-nil-else-pop .
byte-goto-if-nil-else-pop))))
newtag)
(nth 1 newtag)
)
(setcdr tmp (cons (setcdr lap0 newtag) (cdr tmp)))
(if (eq (car (car tmp)) 'byte-goto-if-nil-else-pop)
(setcdr rest (cons (cons 'byte-constant
(byte-compile-get-constant nil))
(cdr rest))))
(setcar lap0 (nth 1 (memq (car (car tmp))
'(byte-goto-if-nil-else-pop
byte-goto-if-not-nil
byte-goto-if-nil
byte-goto-if-not-nil
byte-goto byte-goto))))
)
(setq keep-going t))
)
(setq rest (cdr rest)))
)
(setq byte-compile-constants nil
byte-compile-variables nil)
(setq rest lap)
(while rest
(setq lap0 (car rest)
lap1 (nth 1 rest))
(if (memq (car lap0) byte-constref-ops)
(if (not (eq (car 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)))))
(cond ( (and (eq (car lap0) 'byte-constant)
(eq (car (nth 2 rest)) 'byte-constant)
(eq (cdr lap0) (car (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)
(setcar (cdr (cdr rest)) (cons (car lap1) (cdr lap1)))
(setcar (cdr rest) (cons 'byte-dup 0))
(setq add-depth 1))
((memq (car lap0) '(byte-constant byte-varref))
(setq tmp rest
tmp2 nil)
(while (progn
(while (eq 'byte-dup (car (car (setq tmp (cdr tmp))))))
(and (eq (cdr lap0) (cdr (car tmp)))
(eq (car lap0) (car (car tmp)))))
(setcar tmp (cons 'byte-dup 0))
(setq tmp2 t))
(if tmp2
(byte-compile-log-lap
" %s [dup/%s]...\t-->\t%s dup..." lap0 lap0 lap0)))
((and (eq 'byte-unbind (car lap0))
(eq 'byte-unbind (car lap1)))
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1
(cons 'byte-unbind
(+ (cdr lap0) (cdr lap1))))
(setq keep-going t)
(setq lap (delq lap0 lap))
(setcdr lap1 (+ (cdr lap1) (cdr lap0))))
)
(setq rest (cdr rest)))
(setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth)))
lap)
(provide 'byte-optimize)
(eval-when-compile
(or (byte-code-function-p (symbol-function 'byte-optimize-form))
(assq 'byte-code (symbol-function 'byte-optimize-form))
(let ((byte-optimize nil)
(byte-compile-warnings nil))
(mapcar '(lambda (x)
(or noninteractive (message "compiling %s..." x))
(byte-compile x)
(or noninteractive (message "compiling %s...done" x)))
'(byte-optimize-form
byte-optimize-body
byte-optimize-predicate
byte-optimize-binary-predicate
byte-optimize-form-code-walker
byte-optimize-lapcode))))
nil)