;; 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.
- (cond ;;
- ;; <side-effect-free> pop --> <deleted>
- ;; ...including:
- ;; const-X pop --> <deleted>
- ;; varref-X pop --> <deleted>
- ;; dup pop --> <deleted>
- ;;
- ((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"))))
- ;;
- ;; goto*-X X: --> X:
- ;;
- ((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))
- ;;
- ;; varset-X varref-X --> dup varset-X
- ;; varbind-X varref-X --> dup varbind-X
- ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
- ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
- ;; The latter two can enable other optimizations.
- ;;
- ;; For lexical variables, we could do the same
- ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
- ;; but this is a very minor gain, since dup is stack-ref-0,
- ;; i.e. it's only better if X>5, and even then it comes
- ;; at the cost of an extra stack slot. Let's not bother.
- ((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)
- (macroexp--const-symbol-p
- (car (cdr lap0))))
- (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)
- ;; The stack depth gets locally increased, so we will
- ;; increase maxdepth in case depth = maxdepth here.
- ;; This can cause the third argument to byte-code to
- ;; be larger than necessary.
- (setq add-depth 1))))
- ;;
- ;; dup varset-X discard --> varset-X
- ;; dup varbind-X discard --> varbind-X
- ;; dup stack-set-X discard --> stack-set-X-1
- ;; (the varbind variant can emerge from other optimizations)
- ;;
- ((and (eq 'byte-dup (car lap0))
- (eq 'byte-discard (car lap2))
- (memq (car lap1) '(byte-varset byte-varbind
- byte-stack-set)))
- (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
- (setq keep-going t
- rest (cdr rest))
- (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1)))
- (setq lap (delq lap0 (delq lap2 lap))))
- ;;
- ;; not goto-X-if-nil --> goto-X-if-non-nil
- ;; not goto-X-if-non-nil --> goto-X-if-nil
- ;;
- ;; it is wrong to do the same thing for the -else-pop variants.
- ;;
- ((and (eq 'byte-not (car lap0))
- (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
- (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))
- ;;
- ;; 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:
- ;;
- ;; it is wrong to do the same thing for the -else-pop variants.
- ;;
- ((and (memq (car lap0)
- '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
- (eq 'byte-goto (car lap1)) ; gotoY
- (eq (cdr lap0) lap2)) ; TAG X
- (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)))
- ;;
- ;; const goto-if-* --> whatever
- ;;
- ((and (eq 'byte-constant (car lap0))
- (memq (car lap1) byte-conditional-ops)
- ;; If the `byte-constant's cdr is not a cons cell, it has
- ;; to be an index into the constant pool); even though
- ;; it'll be a constant, that constant is not known yet
- ;; (it's typically a free variable of a closure, so will
- ;; only be known when the closure will be built at
- ;; run-time).
- (consp (cdr lap0)))
- (cond ((if (memq (car lap1) '(byte-goto-if-nil
- 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
- (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))
- ;;
- ;; varref-X varref-X --> varref-X dup
- ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
- ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
- ;; We don't optimize the const-X variations on this here,
- ;; because that would inhibit some goto optimizations; we
- ;; optimize the const-X case after all other optimizations.
- ;;
- ((and (memq (car lap0) '(byte-varref byte-stack-ref))
- (progn
- (setq tmp (cdr rest))
- (setq tmp2 0)
- (while (eq (car (car tmp)) 'byte-dup)
- (setq tmp2 (1+ tmp2))
- (setq tmp (cdr tmp)))
- t)
- (eq (if (eq 'byte-stack-ref (car lap0))
- (+ tmp2 1 (cdr lap0))
- (cdr lap0))
- (cdr (car tmp)))
- (eq (car lap0) (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))
- ;;
- ;; TAG1: TAG2: --> TAG1: <deleted>
- ;; (and other references to TAG2 are replaced with TAG1)
- ;;
- ((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)
- ;; replace references to tag in jump tables, if any
- (dolist (table byte-compile-jump-tables)
- (maphash #'(lambda (value tag)
- (when (equal tag lap0)
- (puthash value lap1 table)))
- table)))
- ;;
- ;; unused-TAG: --> <deleted>
- ;;
- ((and (eq 'TAG (car lap0))
- (not (rassq lap0 lap))
- ;; make sure this tag isn't used in a jump-table
- (cl-loop for table in byte-compile-jump-tables
- when (member lap0 (hash-table-values table))
- return nil finally return t))
- (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))
- ;;
- ;; goto ... --> goto <delete until TAG or end>
- ;; return ... --> return <delete until TAG or end>
- ;; (unless a jump-table is being used, where deleting may affect
- ;; other valid case bodies)
- ;;
- ((and (memq (car lap0) '(byte-goto byte-return))
- (not (memq (car lap1) '(TAG nil)))
- ;; FIXME: Instead of deferring simply when jump-tables are
- ;; being used, keep a list of tags used for switch tags and
- ;; use them instead (see `byte-compile-inline-lapcode').
- (not byte-compile-jump-tables))
- (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))
- ;;
- ;; <safe-op> unbind --> unbind <safe-op>
- ;; (this may enable other optimizations.)
- ;;
- ((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))
- ;;
- ;; varbind-X unbind-N --> discard unbind-(N-1)
- ;; save-excursion unbind-N --> unbind-(N-1)
- ;; save-restriction unbind-N --> unbind-(N-1)
- ;;
- ((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))
+ (cond
+ ;; <side-effect-free> pop --> <deleted>
+ ;; ...including:
+ ;; const-X pop --> <deleted>
+ ;; varref-X pop --> <deleted>
+ ;; dup pop --> <deleted>
+ ;;
+ ((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)))
- (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))
- ;;
- ;; goto*-X ... X: goto-Y --> goto*-Y
- ;; goto-X ... X: return --> return
- ;;
- ((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))))
- ;;
- ;; goto-*-else-pop X ... X: goto-if-* --> whatever
- ;; goto-*-else-pop X ... X: discard --> whatever
- ;;
- ((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))
- ;; Get rid of the -else-pop's and jump one step further.
+ ((= 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"))))
+ ;;
+ ;; goto*-X X: --> X:
+ ;;
+ ((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))
+ ;;
+ ;; varset-X varref-X --> dup varset-X
+ ;; varbind-X varref-X --> dup varbind-X
+ ;; const/dup varset-X varref-X --> const/dup varset-X const/dup
+ ;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
+ ;; The latter two can enable other optimizations.
+ ;;
+ ;; For lexical variables, we could do the same
+ ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
+ ;; but this is a very minor gain, since dup is stack-ref-0,
+ ;; i.e. it's only better if X>5, and even then it comes
+ ;; at the cost of an extra stack slot. Let's not bother.
+ ((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)
+ (macroexp--const-symbol-p
+ (car (cdr lap0))))
+ (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)
+ ;; The stack depth gets locally increased, so we will
+ ;; increase maxdepth in case depth = maxdepth here.
+ ;; This can cause the third argument to byte-code to
+ ;; be larger than necessary.
+ (setq add-depth 1))))
+ ;;
+ ;; dup varset-X discard --> varset-X
+ ;; dup varbind-X discard --> varbind-X
+ ;; dup stack-set-X discard --> stack-set-X-1
+ ;; (the varbind variant can emerge from other optimizations)
+ ;;
+ ((and (eq 'byte-dup (car lap0))
+ (eq 'byte-discard (car lap2))
+ (memq (car lap1) '(byte-varset byte-varbind
+ byte-stack-set)))
+ (byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
+ (setq keep-going t
+ rest (cdr rest))
+ (if (eq 'byte-stack-set (car lap1)) (cl-decf (cdr lap1)))
+ (setq lap (delq lap0 (delq lap2 lap))))
+ ;;
+ ;; not goto-X-if-nil --> goto-X-if-non-nil
+ ;; not goto-X-if-non-nil --> goto-X-if-nil
+ ;;
+ ;; it is wrong to do the same thing for the -else-pop variants.
+ ;;
+ ((and (eq 'byte-not (car lap0))
+ (memq (car lap1) '(byte-goto-if-nil byte-goto-if-not-nil)))
+ (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))
+ ;;
+ ;; 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:
+ ;;
+ ;; it is wrong to do the same thing for the -else-pop variants.
+ ;;
+ ((and (memq (car lap0)
+ '(byte-goto-if-nil byte-goto-if-not-nil)) ; gotoX
+ (eq 'byte-goto (car lap1)) ; gotoY
+ (eq (cdr lap0) lap2)) ; TAG X
+ (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)))
+ ;;
+ ;; const goto-if-* --> whatever
+ ;;
+ ((and (eq 'byte-constant (car lap0))
+ (memq (car lap1) byte-conditional-ops)
+ ;; If the `byte-constant's cdr is not a cons cell, it has
+ ;; to be an index into the constant pool); even though
+ ;; it'll be a constant, that constant is not known yet
+ ;; (it's typically a free variable of a closure, so will
+ ;; only be known when the closure will be built at
+ ;; run-time).
+ (consp (cdr lap0)))
+ (cond ((if (memq (car lap1) '(byte-goto-if-nil
+ 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
+ (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))
+ ;;
+ ;; varref-X varref-X --> varref-X dup
+ ;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
+ ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
+ ;; We don't optimize the const-X variations on this here,
+ ;; because that would inhibit some goto optimizations; we
+ ;; optimize the const-X case after all other optimizations.
+ ;;
+ ((and (memq (car lap0) '(byte-varref byte-stack-ref))
+ (progn
+ (setq tmp (cdr rest))
+ (setq tmp2 0)
+ (while (eq (car (car tmp)) 'byte-dup)
+ (setq tmp2 (1+ tmp2))
+ (setq tmp (cdr tmp)))
+ t)
+ (eq (if (eq 'byte-stack-ref (car lap0))
+ (+ tmp2 1 (cdr lap0))
+ (cdr lap0))
+ (cdr (car tmp)))
+ (eq (car lap0) (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))
+ ;;
+ ;; TAG1: TAG2: --> TAG1: <deleted>
+ ;; (and other references to TAG2 are replaced with TAG1)
+ ;;
+ ((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)
+ ;; replace references to tag in jump tables, if any
+ (dolist (table byte-compile-jump-tables)
+ (maphash #'(lambda (value tag)
+ (when (equal tag lap0)
+ (puthash value lap1 table)))
+ table)))
+ ;;
+ ;; unused-TAG: --> <deleted>
+ ;;
+ ((and (eq 'TAG (car lap0))
+ (not (rassq lap0 lap))
+ ;; make sure this tag isn't used in a jump-table
+ (cl-loop for table in byte-compile-jump-tables
+ when (member lap0 (hash-table-values table))
+ return nil finally return t))
+ (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))
+ ;;
+ ;; goto ... --> goto <delete until TAG or end>
+ ;; return ... --> return <delete until TAG or end>
+ ;; (unless a jump-table is being used, where deleting may affect
+ ;; other valid case bodies)
+ ;;
+ ((and (memq (car lap0) '(byte-goto byte-return))
+ (not (memq (car lap1) '(TAG nil)))
+ ;; FIXME: Instead of deferring simply when jump-tables are
+ ;; being used, keep a list of tags used for switch tags and
+ ;; use them instead (see `byte-compile-inline-lapcode').
+ (not byte-compile-jump-tables))
+ (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))
+ ;;
+ ;; <safe-op> unbind --> unbind <safe-op>
+ ;; (this may enable other optimizations.)
+ ;;
+ ((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))
+ ;;
+ ;; varbind-X unbind-N --> discard unbind-(N-1)
+ ;; save-excursion unbind-N --> unbind-(N-1)
+ ;; save-restriction unbind-N --> unbind-(N-1)
+ ;;
+ ((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))
+ ;;
+ ;; goto*-X ... X: goto-Y --> goto*-Y
+ ;; goto-X ... X: return --> return
+ ;;
+ ((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))))
+ ;;
+ ;; goto-*-else-pop X ... X: goto-if-* --> whatever
+ ;; goto-*-else-pop X ... X: discard --> whatever
+ ;;
+ ((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))
+ ;; Get rid of the -else-pop's and jump one step further.
+ (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))
+ ;;
+ ;; const goto-X ... X: goto-if-* --> whatever
+ ;; const goto-X ... X: discard --> whatever
+ ;;
+ ((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 ((when (consp (cdr lap0))
+ (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))
+ ;; Let next step fix the (const,goto-if*) sequence.
+ (setq rest (cons nil rest))
+ (setq keep-going t))
+ ((or (consp (cdr lap0))
+ (eq (car tmp2) 'byte-discard))
+ ;; Jump one step further
+ (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))))
- (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))
- ;;
- ;; const goto-X ... X: goto-if-* --> whatever
- ;; const goto-X ... X: discard --> whatever
- ;;
- ((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 ((when (consp (cdr lap0))
- (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))
- ;; Let next step fix the (const,goto-if*) sequence.
- (setq rest (cons nil rest))
- (setq keep-going t))
- ((or (consp (cdr lap0))
- (eq (car tmp2) 'byte-discard))
- ;; Jump one step further
- (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))))
- ;;
- ;; 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).
- ;;
- ;; Here again, we could do it for stack-ref/stack-set, but
- ;; that's replacing a stack-ref-Y with a stack-ref-0, which
- ;; is a very minor improvement (if any), at the cost of
- ;; more stack use and more byte-code. Let's not do it.
- ;;
- ((and (eq (car lap1) 'byte-varset)
- (eq (car lap2) 'byte-goto)
- (not (memq (cdr lap2) rest)) ;Backwards jump
- (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)))
- ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp))
- (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))
- ;;
- ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y:
- ;; (This can pull the loop test to the end of the loop)
- ;;
- ((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)))
-;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional"
-;; lap0 lap1 (cdr lap0) (car tmp))
- (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)
- ;; We can handle this case but not the -if-not-nil case,
- ;; because we won't know which non-nil constant to push.
- (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))
- )
+ (setcdr lap1 (car (cdr tmp)))
+ (setq lap (delq lap0 lap))
+ (setq keep-going t))))
+ ;;
+ ;; 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).
+ ;;
+ ;; Here again, we could do it for stack-ref/stack-set, but
+ ;; that's replacing a stack-ref-Y with a stack-ref-0, which
+ ;; is a very minor improvement (if any), at the cost of
+ ;; more stack use and more byte-code. Let's not do it.
+ ;;
+ ((and (eq (car lap1) 'byte-varset)
+ (eq (car lap2) 'byte-goto)
+ (not (memq (cdr lap2) rest)) ;Backwards jump
+ (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)))
+ ;;(byte-compile-log-lap " Pulled %s to end of loop" (car tmp))
+ (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))
+ ;;
+ ;; goto-X Y: ... X: goto-if*-Y --> goto-if-not-*-X+1 Y:
+ ;; (This can pull the loop test to the end of the loop)
+ ;;
+ ((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)))
+ ;; (byte-compile-log-lap " %s %s, %s %s --> moved conditional"
+ ;; lap0 lap1 (cdr lap0) (car tmp))
+ (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)
+ ;; We can handle this case but not the -if-not-nil case,
+ ;; because we won't know which non-nil constant to push.
+ (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)))
)
;; Cleanup stage:
projects / emacs.git / commitdiff