(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"))
+ ;; Newer byte codes for stack-ref make the slot 0 non-nil again.
+ ;; But the "old disassembler" is *really* ancient by now.
+ ;; (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)
;; ((lambda ...) ...)
(defun byte-compile-unfold-lambda (form &optional name)
+ ;; In lexical-binding mode, let and functions don't bind vars in the same way
+ ;; (let obey special-variable-p, but functions don't). This doesn't matter
+ ;; here, because function's behavior is underspecified so it can safely be
+ ;; turned into a `let', even though the reverse is not true.
(or name (setq name "anonymous lambda"))
(let ((lambda (car form))
(values (cdr form)))
;; However, don't actually bother calling `ignore'.
`(prog1 nil . ,(mapcar 'byte-optimize-form (cdr form))))
+ ((eq fn 'internal-make-closure)
+ form)
+
((not (symbolp fn))
+ (debug)
(byte-compile-warn "`%s' is a malformed function"
(prin1-to-string fn))
form)
(defconst byte-constref-ops
'(byte-constant byte-constant2 byte-varref byte-varset byte-varbind))
+;; Used and set dynamically in byte-decompile-bytecode-1.
+(defvar bytedecomp-op)
+(defvar bytedecomp-ptr)
+(defvar bytedecomp-bytes)
+
;; This function extracts the bitfields from variable-length opcodes.
;; Originally defined in disass.el (which no longer uses it.)
-
(defun disassemble-offset ()
"Don't call this!"
;; fetch and return the offset for the current opcode.
;; return nil if this opcode has no offset
- ;; Used and set dynamically in byte-decompile-bytecode-1.
- (defvar bytedecomp-op)
- (defvar bytedecomp-ptr)
- (defvar bytedecomp-bytes)
(cond ((< bytedecomp-op byte-nth)
(let ((tem (logand bytedecomp-op 7)))
(setq bytedecomp-op (logand bytedecomp-op 248))
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-stack-ref))
+ byte-current-buffer byte-stack-ref ;; byte-closed-var
+ ))
(defconst byte-compile-side-effect-free-ops
(nconc
;; 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 ((= stack-adjust 1)
+ (cond ((= tmp 1)
(byte-compile-log-lap
" %s discard\t-->\t<deleted>" lap0)
(setq lap (delq lap0 (delq lap1 lap))))
- ((= stack-adjust 0)
+ ((= tmp 0)
(byte-compile-log-lap
" %s discard\t-->\t<deleted> discard" lap0)
(setq lap (delq lap0 lap)))
- ((= stack-adjust -1)
+ ((= 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")))
- (setq stack-adjust (1- stack-adjust)))
+ ((error "Optimizer error: too much on the stack"))))
;;
;; goto*-X X: --> X:
;;
byte-stack-set)))
(byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
(setq keep-going t
- rest (cdr rest)
- stack-adjust -1)
+ rest (cdr rest))
(if (eq 'byte-stack-set (car lap1)) (decf (cdr lap1)))
(setq lap (delq lap0 (delq lap2 lap))))
;;
'byte-goto-if-not-nil
'byte-goto-if-nil))
(setq lap (delq lap0 lap))
- (setq keep-going t
- stack-adjust 0))
+ (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:
(byte-compile-log-lap " %s %s %s:\t-->\t%s %s:"
lap0 lap1 lap2
(cons inverse (cdr lap1)) lap2)
- (setq lap (delq lap0 lap)
- stack-adjust 0)
+ (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))
+ (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 (or (eq (car lap1) 'byte-goto-if-nil)
- (eq (car lap1) 'byte-goto-if-nil-else-pop))
- (car (cdr lap0))
- (not (car (cdr lap0))))
+ (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)
(when (memq (car lap1) byte-goto-always-pop-ops)
(setq lap (delq lap0 lap)))
(setcar lap1 'byte-goto)))
- (setq keep-going t
- stack-adjust 0))
+ (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
+ ;; 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.
(setq keep-going t)
(setcar (car tmp) 'byte-dup)
(setcdr (car tmp) 0)
- (setq rest tmp
- stack-adjust (+ 2 tmp2)))
+ (setq rest tmp))
;;
;; 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
- stack-adjust 0))
+ (setq keep-going t))
;;
;; varbind-X unbind-N --> discard unbind-(N-1)
;; save-excursion unbind-N --> unbind-(N-1)
(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)))
+ (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)))
- (t
+ (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>"
(setcdr tmp (cons (byte-compile-make-tag)
(cdr tmp))))
(setcdr lap1 (car (cdr tmp)))
- (setq lap (delq lap0 lap))))
- (setq keep-going t
- stack-adjust 0))
+ (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
(eq (car lap2) 'byte-goto)
(not (memq (cdr lap2) rest)) ;Backwards jump
(eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
- (if (eq (car lap1) 'byte-varset) 'byte-varref
- ;; 'byte-stack-ref
- ))
+ 'byte-varref)
(eq (cdr (car tmp)) (cdr lap1))
- (not (and (eq (car lap1) 'byte-varref)
- (memq (car (cdr lap1)) byte-boolean-vars))))
+ (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
byte-goto-if-not-nil
byte-goto byte-goto))))
)
- (setq keep-going t
- stack-adjust (and (not (eq (car lap0) 'byte-goto)) -1)))
+ (setq keep-going t))
)
-
- (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
- stack-depth initial-stack-depth)
+ (setq rest lap)
(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))
+ (if (memq (car lap0) '(byte-constant byte-constant2))
(unless (memq (cdr lap0) byte-compile-constants)
(setq byte-compile-constants (cons (cdr lap0)
byte-compile-constants)))
'byte-discardN))
(setcdr lap1 (1+ tmp3))
(setcdr (cdr rest) tmp)
- (setq stack-adjust 0)
(byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s"
lap0 lap1))
(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))
+ (setcar lap1 'byte-discardN))
;;
;; discardN-preserve-tos-X discardN-preserve-tos-Y -->
(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)))
;;
;; 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))
)
-
- (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