(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)
(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))))))
((>= 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))))
(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))
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
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.
;; 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
(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.
((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:
;;
;; 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)
;;
((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
'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:
(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)))
;;
(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
;; 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))
(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)
(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)
""))
(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
;;
(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
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
;; 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))
(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)
HCoop / bpt / emacs.git / blobdiff