(let ((side-effect-free (if byte-compile-delete-errors
byte-compile-side-effect-free-ops
byte-compile-side-effect-and-error-free-ops))
+ ;; Ops taking and produce a single value on the stack.
+ (unary-ops '( byte-not byte-length byte-list1 byte-nreverse
+ byte-car byte-cdr byte-car-safe byte-cdr-safe
+ byte-symbolp byte-consp byte-stringp
+ byte-listp byte-integerp byte-numberp
+ byte-add1 byte-sub1 byte-negate
+ ;; There are more of these but the list is
+ ;; getting long and the gain is typically small.
+ ))
+ ;; Ops producing a single result without looking at the stack.
+ (producer-ops '( byte-constant byte-varref
+ 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-widen))
(add-depth 0)
(keep-going 'first-time)
;; Create a cons cell as head of the list so that removing the first
;; const, varref, point etc.
;;
((and (eq (car (nth 2 rest)) 'byte-return)
- (memq (car lap1) '( byte-constant byte-varref
- 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-widen))
+ (memq (car lap1) producer-ops)
(or (memq (car lap0) '( byte-discard byte-discardN
byte-discardN-preserve-tos
byte-stack-set))
lap0 lap1 (nth 2 rest) lap1 (nth 2 rest)))
;;
- ;; discardN-preserve-tos OP return --> OP return
- ;; dup OP return --> OP return
- ;; where OP is 1->1 in stack use, like `not'.
+ ;; (discardN-preserve-tos|dup) UNARY return --> UNARY return
+ ;; where UNARY takes and produces a single value on the stack
;;
;; FIXME: ideally we should run this backwards, so that we could do
;; discardN-preserve-tos OP1...OPn return -> OP1..OPn return
;; but that would require a different approach.
;;
((and (eq (car (nth 2 rest)) 'byte-return)
- (memq (car lap1)
- '( byte-not
- byte-symbolp byte-consp byte-stringp
- byte-listp byte-integerp byte-numberp
- byte-list1
- byte-car byte-cdr byte-car-safe byte-cdr-safe
- byte-length
- byte-add1 byte-sub1 byte-negate byte-nreverse
- ;; There are more of these but the list is
- ;; getting long and the gain is small.
- ))
+ (memq (car lap1) unary-ops)
(or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
(and (eq (car lap0) 'byte-stack-set)
(eql (cdr lap0) 1))))
(push newjmp (cdr rest)))
t)))))
+ ;;
+ ;; UNARY discardN-preserve-tos --> discardN-preserve-tos UNARY
+ ;; where UNARY takes and produces a single value on the stack
+ ;;
+ ((and (memq (car lap0) unary-ops)
+ (or (eq (car lap1) 'byte-discardN-preserve-tos)
+ (and (eq (car lap1) 'byte-stack-set)
+ (eql (cdr lap1) 1)))
+ ;; unless followed by return (which will eat the discard)
+ (not (eq (car lap2) 'byte-return)))
+ (setq keep-going t)
+ (byte-compile-log-lap " %s %s\t-->\t%s %s" lap0 lap1 lap1 lap0)
+ (setcar rest lap1)
+ (setcar (cdr rest) lap0))
+
;;
- ;; const discardN-preserve-tos ==> discardN const
- ;; const stack-set(1) ==> discard const
+ ;; PRODUCER discardN-preserve-tos(X) --> discard(X) PRODUCER
+ ;; where PRODUCER pushes a result without looking at the stack:
+ ;; const, varref, point etc.
;;
- ((and (eq (car lap0) 'byte-constant)
+ ((and (memq (car lap0) producer-ops)
(or (eq (car lap1) 'byte-discardN-preserve-tos)
(and (eq (car lap1) 'byte-stack-set)
- (eql (cdr lap1) 1))))
+ (eql (cdr lap1) 1)))
+ ;; unless followed by return (which will eat the discard)
+ (not (eq (car lap2) 'byte-return)))
(setq keep-going t)
(let ((newdiscard (if (eql (cdr lap1) 1)
(cons 'byte-discard nil)
" %s %s\t-->\t%s %s" lap0 lap1 newdiscard lap0)
(setf (car rest) newdiscard)
(setf (cadr rest) lap0)))
+
(t
;; If no rule matched, advance and try again.
(setq prev (cdr prev))))))))