diff options
Diffstat (limited to 'lisp/emacs-lisp/byte-opt.el')
| -rw-r--r-- | lisp/emacs-lisp/byte-opt.el | 263 |
1 files changed, 219 insertions, 44 deletions
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 0b4043b1f2a..4a073a8e2e9 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -187,8 +187,8 @@ (eval-when-compile (require 'cl)) (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")) +;; (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) @@ -282,7 +282,8 @@ (byte-code ,string ,(aref fn 2) ,(aref fn 3))) (cdr form))) (if (eq (car-safe fn) 'lambda) - (cons fn (cdr form)) + (macroexpand-all (cons fn (cdr form)) + byte-compile-macro-environment) ;; Give up on inlining. form)))))) @@ -1335,14 +1336,15 @@ ((>= op byte-constant) (prog1 (- op byte-constant) ;offset in opcode (setq op byte-constant))) - ((and (>= op byte-constant2) - (<= op byte-goto-if-not-nil-else-pop)) + ((or (and (>= op byte-constant2) + (<= op byte-goto-if-not-nil-else-pop)) + (= op byte-stack-set2)) (setq ptr (1+ ptr)) ;offset in next 2 bytes (+ (aref bytes ptr) (progn (setq ptr (1+ ptr)) (lsh (aref bytes ptr) 8)))) ((and (>= op byte-listN) - (<= op byte-insertN)) + (<= op byte-discardN)) (setq ptr (1+ ptr)) ;offset in next byte (aref bytes ptr)))) @@ -1403,7 +1405,16 @@ (if (= ptr (1- length)) (setq op nil) (setq offset (or endtag (setq endtag (byte-compile-make-tag))) - op 'byte-goto)))) + op 'byte-goto))) + ((eq op 'byte-stack-set2) + (setq op 'byte-stack-set)) + ((and (eq op 'byte-discardN) (>= offset #x80)) + ;; The top bit of the operand for byte-discardN is a flag, + ;; saying whether the top-of-stack is preserved. In + ;; lapcode, we represent this by using a different opcode + ;; (with the flag removed from the operand). + (setq op 'byte-discardN-preserve-tos) + (setq offset (- offset #x80)))) ;; lap = ( [ (pc . (op . arg)) ]* ) (setq lap (cons (cons optr (cons op (or offset 0))) lap)) @@ -1459,7 +1470,7 @@ 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)) + byte-current-buffer byte-interactive-p byte-stack-ref)) (defconst byte-compile-side-effect-free-ops (nconc @@ -1468,7 +1479,7 @@ 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-member byte-assq byte-quo byte-rem byte-vec-ref) byte-compile-side-effect-and-error-free-ops)) ;; This crock is because of the way DEFVAR_BOOL variables work. @@ -1501,12 +1512,50 @@ ;; The variable `byte-boolean-vars' is now primitive and updated ;; automatically by DEFVAR_BOOL. +(defmacro byte-opt-update-stack-params (stack-adjust stack-depth lap0 rest lap) + "...macro used by byte-optimize-lapcode..." + `(progn + (byte-compile-log-lap "Before %s [depth = %s]" ,lap0 ,stack-depth) + (cond ((eq (car ,lap0) 'TAG) + ;; A tag can encode the expected stack depth. + (when (cddr ,lap0) + ;; First, check to see if our notion of the current stack + ;; depth agrees with this tag. We don't check at the + ;; beginning of the function, because the presence of + ;; lexical arguments means the first tag will have a + ;; non-zero offset. + (when (and (not (eq ,rest ,lap)) ; not at first insn + ,stack-depth ; not just after a goto + (not (= (cddr ,lap0) ,stack-depth))) + (error "Compiler error: optimizer is confused about %s: + %s != %s at lapcode %s" ',stack-depth (cddr ,lap0) ,stack-depth ,lap0)) + ;; Now set out current depth from this tag + (setq ,stack-depth (cddr ,lap0))) + (setq ,stack-adjust 0)) + ((memq (car ,lap0) '(byte-goto byte-return)) + ;; These insns leave us in an unknown state + (setq ,stack-adjust nil)) + ((car ,lap0) + ;; Not a no-op, set ,stack-adjust for lap0. ,stack-adjust will + ;; be added to ,stack-depth at the end of the loop, so any code + ;; that modifies the instruction sequence must adjust this too. + (setq ,stack-adjust + (byte-compile-stack-adjustment (car ,lap0) (cdr ,lap0))))) + (byte-compile-log-lap "Before %s [depth => %s, adj = %s]" ,lap0 ,stack-depth ,stack-adjust) + )) + (defun byte-optimize-lapcode (lap &optional for-effect) "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 lap1 lap2 + stack-adjust + stack-depth + (initial-stack-depth + (if (and lap (eq (car (car lap)) 'TAG)) + (cdr (cdr (car lap))) + 0)) (keep-going 'first-time) (add-depth 0) rest tmp tmp2 tmp3 @@ -1517,12 +1566,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (or (eq keep-going 'first-time) (byte-compile-log-lap " ---- next pass")) (setq rest lap + stack-depth initial-stack-depth keep-going nil) (while rest (setq lap0 (car rest) lap1 (nth 1 rest) lap2 (nth 2 rest)) + (byte-opt-update-stack-params stack-adjust stack-depth lap0 rest lap) + ;; You may notice that sequences like "dup varset discard" are ;; optimized but sequences like "dup varset TAG1: discard" are not. ;; You may be tempted to change this; resist that temptation. @@ -1536,22 +1588,22 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ((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) + (cond ((= stack-adjust 1) (byte-compile-log-lap " %s discard\t-->\t<deleted>" lap0) (setq lap (delq lap0 (delq lap1 lap)))) - ((= tmp 0) + ((= stack-adjust 0) (byte-compile-log-lap " %s discard\t-->\t<deleted> discard" lap0) (setq lap (delq lap0 lap))) - ((= tmp -1) + ((= stack-adjust -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")))) + ((error "Optimizer error: too much on the stack"))) + (setq stack-adjust (1- stack-adjust))) ;; ;; goto*-X X: --> X: ;; @@ -1576,10 +1628,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup ;; The latter two can enable other optimizations. ;; - ((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)) + ((or (and (eq 'byte-varref (car lap2)) + (eq (cdr lap1) (cdr lap2)) + (memq (car lap1) '(byte-varset byte-varbind))) + (and (eq (car lap2) 'byte-stack-ref) + (eq (car lap1) 'byte-stack-set) + (eq (cdr lap1) (cdr lap2)))) + (if (and (eq 'byte-varref (car lap2)) + (setq tmp (memq (car (cdr lap2)) byte-boolean-vars)) (not (eq (car lap0) 'byte-constant))) nil (setq keep-going t) @@ -1611,10 +1667,11 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; ((and (eq 'byte-dup (car lap0)) (eq 'byte-discard (car lap2)) - (memq (car lap1) '(byte-varset byte-varbind))) + (memq (car lap1) '(byte-varset byte-varbind byte-stack-set byte-vec-set))) (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1) (setq keep-going t - rest (cdr rest)) + rest (cdr rest) + stack-adjust -1) (setq lap (delq lap0 (delq lap2 lap)))) ;; ;; not goto-X-if-nil --> goto-X-if-non-nil @@ -1636,7 +1693,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." 'byte-goto-if-not-nil 'byte-goto-if-nil)) (setq lap (delq lap0 lap)) - (setq keep-going t)) + (setq keep-going t + stack-adjust 0)) ;; ;; goto-X-if-nil goto-Y X: --> goto-Y-if-non-nil X: ;; goto-X-if-non-nil goto-Y X: --> goto-Y-if-nil X: @@ -1652,7 +1710,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (byte-compile-log-lap " %s %s %s:\t-->\t%s %s:" lap0 lap1 lap2 (cons inverse (cdr lap1)) lap2) - (setq lap (delq lap0 lap)) + (setq lap (delq lap0 lap) + stack-adjust 0) (setcar lap1 inverse) (setq keep-going t))) ;; @@ -1669,15 +1728,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (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)))) + (byte-compile-log-lap " %s %s\t-->\t%s" + lap0 lap1 + (cons 'byte-goto (cdr lap1))) + (when (memq (car lap1) byte-goto-always-pop-ops) + (setq lap (delq lap0 lap))) (setcar lap1 'byte-goto))) - (setq keep-going t)) + (setq keep-going t + stack-adjust 0)) ;; ;; varref-X varref-X --> varref-X dup ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup @@ -1685,14 +1743,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; because that would inhibit some goto optimizations; we ;; optimize the const-X case after all other optimizations. ;; - ((and (eq 'byte-varref (car lap0)) + ((and (memq (car lap0) '(byte-varref byte-stack-ref)) (progn - (setq tmp (cdr rest)) + (setq tmp (cdr rest) tmp2 0) (while (eq (car (car tmp)) 'byte-dup) - (setq tmp (cdr tmp))) + (setq tmp (cdr tmp) tmp2 (1+ tmp2))) t) - (eq (cdr lap0) (cdr (car tmp))) - (eq 'byte-varref (car (car tmp)))) + (eq (car lap0) (car (car tmp))) + (eq (cdr lap0) (cdr (car tmp)))) (if (memq byte-optimize-log '(t byte)) (let ((str "")) (setq tmp2 (cdr rest)) @@ -1704,7 +1762,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (setq keep-going t) (setcar (car tmp) 'byte-dup) (setcdr (car tmp) 0) - (setq rest tmp)) + (setq rest tmp + stack-adjust (+ 2 tmp2))) ;; ;; TAG1: TAG2: --> TAG1: <deleted> ;; (and other references to TAG2 are replaced with TAG1) @@ -1771,7 +1830,8 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (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)) + (setq keep-going t + stack-adjust 0)) ;; ;; varbind-X unbind-N --> discard unbind-(N-1) ;; save-excursion unbind-N --> unbind-(N-1) @@ -1797,6 +1857,14 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." "")) (setq keep-going t)) ;; + ;; stack-ref-N --> dup ; where N is TOS + ;; + ((and (eq (car lap0) 'byte-stack-ref) + (= (cdr lap0) (1- stack-depth))) + (setcar lap0 'byte-dup) + (setcdr lap0 nil) + (setq keep-going t)) + ;; ;; goto*-X ... X: goto-Y --> goto*-Y ;; goto-X ... X: return --> return ;; @@ -1873,20 +1941,22 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (cdr tmp)))) (setcdr lap1 (car (cdr tmp))) (setq lap (delq lap0 lap)))) - (setq keep-going t)) + (setq keep-going t + stack-adjust 0)) ;; ;; X: varref-Y ... varset-Y goto-X --> ;; X: varref-Y Z: ... dup varset-Y goto-Z ;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.) ;; (This is so usual for while loops that it is worth handling). ;; - ((and (eq (car lap1) 'byte-varset) + ((and (memq (car lap1) '(byte-varset byte-stack-set)) (eq (car lap2) 'byte-goto) (not (memq (cdr lap2) rest)) ;Backwards jump (eq (car (car (setq tmp (cdr (memq (cdr lap2) lap))))) - 'byte-varref) + (if (eq (car lap1) 'byte-varset) 'byte-varref 'byte-stack-ref)) (eq (cdr (car tmp)) (cdr lap1)) - (not (memq (car (cdr lap1)) byte-boolean-vars))) + (not (and (eq (car lap1) 'byte-varref) + (memq (car (cdr lap1)) byte-boolean-vars)))) ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp)) (let ((newtag (byte-compile-make-tag))) (byte-compile-log-lap @@ -1943,10 +2013,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." byte-goto-if-not-nil byte-goto byte-goto)))) ) - (setq keep-going t)) + (setq keep-going t + stack-adjust (and (not (eq (car lap0) 'byte-goto)) -1))) ) + + (setq stack-depth + (and stack-depth stack-adjust (+ stack-depth stack-adjust))) (setq rest (cdr rest))) ) + ;; Cleanup stage: ;; Rebuild byte-compile-constants / byte-compile-variables. ;; Simple optimizations that would inhibit other optimizations if they @@ -1954,10 +2029,13 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." ;; need to do more than once. (setq byte-compile-constants nil byte-compile-variables nil) - (setq rest lap) + (setq rest lap + stack-depth initial-stack-depth) + (byte-compile-log-lap " ---- final pass") (while rest (setq lap0 (car rest) lap1 (nth 1 rest)) + (byte-opt-update-stack-params stack-adjust stack-depth lap0 rest lap) (if (memq (car lap0) byte-constref-ops) (if (or (eq (car lap0) 'byte-constant) (eq (car lap0) 'byte-constant2)) @@ -2004,11 +2082,108 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (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)))) + + ;; + ;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos + ;; stack-set-M [discard/discardN ...] --> discardN + ;; + ((and (eq (car lap0) 'byte-stack-set) + (memq (car lap1) '(byte-discard byte-discardN)) + (progn + ;; See if enough discard operations follow to expose or + ;; destroy the value stored by the stack-set. + (setq tmp (cdr rest)) + (setq tmp2 (- stack-depth 2 (cdr lap0))) + (setq tmp3 0) + (while (memq (car (car tmp)) '(byte-discard byte-discardN)) + (if (eq (car (car tmp)) 'byte-discard) + (setq tmp3 (1+ tmp3)) + (setq tmp3 (+ tmp3 (cdr (car tmp))))) + (setq tmp (cdr tmp))) + (>= tmp3 tmp2))) + ;; Do the optimization + (setq lap (delq lap0 lap)) + (cond ((= tmp2 tmp3) + ;; The value stored is the new TOS, so pop one more value + ;; (to get rid of the old value) using the TOS-preserving + ;; discard operator. + (setcar lap1 'byte-discardN-preserve-tos) + (setcdr lap1 (1+ tmp3))) + (t + ;; Otherwise, the value stored is lost, so just use a + ;; normal discard. + (setcar lap1 'byte-discardN) + (setcdr lap1 tmp3))) + (setcdr (cdr rest) tmp) + (setq stack-adjust 0) + (byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s" + lap0 lap1)) + + ;; + ;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y --> + ;; discardN-(X+Y) + ;; + ((and (memq (car lap0) + '(byte-discard + byte-discardN + byte-discardN-preserve-tos)) + (memq (car lap1) '(byte-discard byte-discardN))) + (setq lap (delq lap0 lap)) + (byte-compile-log-lap + " %s %s\t-->\t(discardN %s)" + lap0 lap1 + (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) + (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) + (setcdr lap1 (+ (if (eq (car lap0) 'byte-discard) 1 (cdr lap0)) + (if (eq (car lap1) 'byte-discard) 1 (cdr lap1)))) + (setcar lap1 'byte-discardN) + (setq stack-adjust 0)) + + ;; + ;; discardN-preserve-tos-X discardN-preserve-tos-Y --> + ;; discardN-preserve-tos-(X+Y) + ;; + ((and (eq (car lap0) 'byte-discardN-preserve-tos) + (eq (car lap1) 'byte-discardN-preserve-tos)) + (setq lap (delq lap0 lap)) + (setcdr lap1 (+ (cdr lap0) (cdr lap1))) + (setq stack-adjust 0) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 (car rest))) + + ;; + ;; discardN-preserve-tos return --> return + ;; dup return --> return + ;; stack-set-N return --> return ; where N is TOS-1 + ;; + ((and (eq (car lap1) 'byte-return) + (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup)) + (and (eq (car lap0) 'byte-stack-set) + (= (cdr lap0) (- stack-depth 2))))) + ;; the byte-code interpreter will pop the stack for us, so + ;; we can just leave stuff on it + (setq lap (delq lap0 lap)) + (setq stack-adjust 0) + (byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1)) + + ;; + ;; dup stack-set-N return --> return ; where N is TOS + ;; + ((and (eq (car lap0) 'byte-dup) + (eq (car lap1) 'byte-stack-set) + (eq (car (car (cdr (cdr rest)))) 'byte-return) + (= (cdr lap1) (1- stack-depth))) + (setq lap (delq lap0 (delq lap1 lap))) + (setq rest (cdr rest)) + (setq stack-adjust 0) + (byte-compile-log-lap " dup %s return\t-->\treturn" lap1)) ) + + (setq stack-depth + (and stack-depth stack-adjust (+ stack-depth stack-adjust))) (setq rest (cdr rest))) + (setq byte-compile-maxdepth (+ byte-compile-maxdepth add-depth))) lap) |