Re: byte-code optimizations

[Paul Pogonyshev <pogonyshev@gmx.net>]

Stefan wrote:

> > +	    ;; dup varbind-X [car/cdr ...] unbind-1 --> [car/cdr ...]
>
> I get the same optimization result by adding
>
>         car/cdr/equal/nth unbind --> unbind car/cdr/equal/nth
>
> Problem is that such an optimization is only safe if car/cdr/... is not
> affected by the bound thing.  If the `unbind' unbinds a variable, then
> I think it's always safe.  So I've added to the lapcode optimizer some
> logic to keep track of the specpdl stack so that I can distinguish an
> unbind that terminates a varbind from one that terminates an
> unwind-protect.

Seems like you are trying to solve this problem (in comment):

(defconst byte-after-unbind-ops
   '(byte-constant byte-dup
     byte-symbolp byte-consp byte-stringp byte-listp byte-numberp byte-integerp
     byte-eq byte-not
     byte-cons byte-list1 byte-list2	; byte-list3 byte-list4
     byte-interactive-p)
   ;; How about other side-effect-free-ops?  Is it safe to move an
   ;; error invocation (such as from nth) out of an unwind-protect?
   ;; No, it is not, because the unwind-protect forms can alter
   ;; the inside of the object to which nth would apply.
   ;; For the same reason, byte-equal was deleted from this list.
   "Byte-codes that can be moved past an unbind.")

If you can properly track `unwind-protect' unbinds, then your
optimization is probably better.

> Better yet: you also get the exact same result code (without any lapcode
> optimization) if you use
>
>    (defsubst* cddr (x) (cdr (cdr x)))
>
> I.e. using the `defubst*' (from CL).

Is there a reason to use `defsubst' then?  Do `defsubst' and
`defsubst*' differ in result?  (Frankly speaking, I cannot read
it.)

RMS wrote:

>     In other words, it squeezes the unnecessary binding out of each
>     `c[ad][ad]r'.  Three commands per each substitution.
> 
> I see, those wasteful operations come from defsubst expansion.  Can
> you generalize your optimization so it is not limited to car and cdr
> operations in the middle?  It ought to be simple to handle many other
> cases, as long as there are no jumps inside.

My latest version is below.  I generalized it (skips all byte-codes
in `byte-compile-side-effect-free-dynamically-safe-ops' plus
`byte-varref' which reference another variable.  I also implemented
the `binding-is-magic' property suggested in TODO section and a few
other generalizations.

However, we (actually Stefan) need to decide whether we want to try
optimizing unbinds without visible bindings.  I.e. I'm optimizing

	varbind-X ... unbind-N --> discard ... unbind-(N-1)

while Stefan suggests a more general

	... unbind-1 --> unbind-1 ...

which is then followuped by other (existing) optimizations.

Paul



--- byte-opt.el	22 Mar 2004 13:21:08 -0200	1.75
+++ byte-opt.el	19 Sep 2004 14:00:27 -0200	
@@ -1467,6 +1467,33 @@ of FORM by signalling the error at compi
      byte-member byte-assq byte-quo byte-rem)
    byte-compile-side-effect-and-error-free-ops))
 
+(defconst byte-compile-side-effect-free-dynamically-safe-ops
+  '(;; Same as `byte-compile-side-effect-free-ops' but without
+    ;; `byte-varref', `byte-symbol-value' and certain editing
+    ;; primitives.
+    byte-constant byte-dup byte-symbolp byte-consp byte-stringp byte-listp
+    byte-integerp byte-numberp byte-eq byte-equal byte-not byte-car-safe
+    byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max
+    byte-point-min byte-following-char byte-preceding-char
+    byte-eolp byte-eobp byte-bolp byte-bobp
+    ;;
+    byte-nth byte-memq byte-car byte-cdr byte-length byte-aref
+    byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1
+    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-string= byte-string< byte-nthcdr byte-elt
+    byte-member byte-assq byte-quo byte-rem))
+
+(put 'debug-on-error 'binding-is-magic t)
+(put 'debug-on-abort 'binding-is-magic t)
+(put 'debug-on-next-call 'binding-is-magic t)
+(put 'inhibit-quit 'binding-is-magic t)
+(put 'quit-flag 'binding-is-magic t)
+(put 't 'binding-is-magic t)
+(put 'nil 'binding-is-magic t)
+(put 'gc-cons-threshold 'binding-is-magic t)
+(put 'track-mouse 'binding-is-magic t)
+
 ;; This crock is because of the way DEFVAR_BOOL variables work.
 ;; Consider the code
 ;;
@@ -1871,6 +1898,55 @@ If FOR-EFFECT is non-nil, the return val
 		      (setq lap (delq lap0 lap))))
 	       (setq keep-going t))
 	      ;;
+	      ;; varbind-X [car/cdr/ ...] unbind-1 --> discard [car/cdr/ ...]
+	      ;; varbind-X [car/cdr/ ...] unbind-N
+	      ;;   --> discard [car/cdr/ ...] unbind-(N-1)
+	      ;;
+	      ((and (eq 'byte-varbind (car lap1))
+		    (not (get (cadr lap1) 'binding-is-magic)))
+	       (setq tmp (cdr rest))
+	       (while
+		   (or
+		    (memq (caar (setq tmp (cdr tmp)))
+			  byte-compile-side-effect-free-dynamically-safe-ops)
+		    (and (eq (caar tmp) 'byte-varref)
+			 (not (eq (cadr (car tmp)) (cadr lap1))))))
+	       (when (eq 'byte-unbind (caar tmp))
+		 ;; Avoid evalling this crap when not logging anyway
+		 (when (memq byte-optimize-log '(t lap))
+		   (let ((format-string)
+			 (args))
+		     (if (and (= (aref byte-stack+-info (symbol-value (car lap0)))
+				1)
+			      (memq (car lap0) side-effect-free))
+			 (setq format-string
+			       "  %s %s [car/cdr/ ...] %s\t-->\t[car/cdr/ ...]"
+			       args (list lap0 lap1 (car tmp)))
+		       (setq format-string
+			     "  %s [car/cdr/ ...] %s\t-->\t%s [car/cdr/ ...]"
+			     args (list lap1 (car tmp) (cons 'byte-discard 0))))
+		     (when (> (cdar tmp) 1)
+		       (setq format-string (concat format-string " %s"))
+		       (nconc args (list (cons 'byte-unbind (1- (cdar tmp))))))
+		     (apply 'byte-compile-log-lap-1 format-string args)))
+		 ;; Do the real work
+		 (if (and (= (aref byte-stack+-info (symbol-value (car lap0)))
+			     1)
+			  (memq (car lap0) side-effect-free))
+		     ;; Optimization: throw const/dup/... varbind right away.
+		     (progn
+		       (setcar rest (nth 2 rest))
+		       (setcdr rest (nthcdr 3 rest)))
+		   (setcar lap1 'byte-discard)
+		   (setcdr lap1 0))
+		 (if (= (cdar tmp) 1)
+		     (progn
+		       ;; Throw away unbind-1
+		       (setcar tmp (nth 1 tmp))
+		       (setcdr tmp (nthcdr 2 tmp)))
+		   (setcdr (car tmp) (1- (cdar tmp))))
+		 (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.)