Commits

Aidan Kehoe committed e9c3fe8

Co-operate with the byte-optimizer in the bytecomp.el labels implementation.

lisp/ChangeLog addition:

2012-05-05 Aidan Kehoe <kehoea@parhasard.net>

Co-operate with the byte-optimizer in the bytecomp.el labels
implementation, don't work against it.

* byte-optimize.el:
* byte-optimize.el (byte-compile-inline-expand):
Call #'byte-compile-unfold-lambda explicitly here, don't assume
that the byte-optimizer will do it.
* byte-optimize.el (byte-compile-unfold-lambda):
Call #'byte-optimize-body on the body, don't just mapcar
#'byte-optimize-form along it.
* byte-optimize.el (byte-optimize-lambda): New. Optimize a lambda
form.
* byte-optimize.el (byte-optimize-form-code-walker):
Descend lambda expressions, defun, and defmacro, relevant for
lexically-oriented operators like #'labels.
* byte-optimize.el (byte-optimize-body): Only return a non-eq
object if we've actually optimized something
* bytecomp.el (byte-compile-initial-macro-environment):
In the labels implementation, work with the byte optimizer, not
against it; warn when labels are defined but not used,
automatically inline labels that are used only once.
* bytecomp.el (byte-recompile-directory):
No need to wrap #'byte-compile-report-error in a lambda with
#'call-with-condition-handler here.
* bytecomp.el (byte-compile-form):
Don't inline compiled-function objects, they're probably labels.
* bytecomp.el (byte-compile-funcall):
No longer inline lambdas, trust the byte optimizer to have done it
properly, even for labels.
* cl-extra.el (cl-macroexpand-all):
Treat labels established by the byte compiler distinctly from
those established by cl-macs.el.
* cl-macs.el (cl-do-proclaim):
Treat labels established by the byte compiler distinctly from
those established by cl-macs.el.
* gui.el (make-gui-button):
When referring to the #'gui-button-action label, quote it using
function, otherwise there's a warning from the byte compiler.

Comments (0)

Files changed (6)

+2012-05-05  Aidan Kehoe  <kehoea@parhasard.net>
+
+	Co-operate with the byte-optimizer in the bytecomp.el labels
+	implementation, don't work against it.
+
+	* byte-optimize.el:
+	* byte-optimize.el (byte-compile-inline-expand):
+	Call #'byte-compile-unfold-lambda explicitly here, don't assume
+	that the byte-optimizer will do it.
+	* byte-optimize.el (byte-compile-unfold-lambda):
+	Call #'byte-optimize-body on the body, don't just mapcar
+	#'byte-optimize-form along it.
+	* byte-optimize.el (byte-optimize-lambda): New. Optimize a lambda
+	form. 
+	* byte-optimize.el (byte-optimize-form-code-walker):
+	Descend lambda expressions, defun, and defmacro, relevant for
+	lexically-oriented operators like #'labels.
+	* byte-optimize.el (byte-optimize-body): Only return a non-eq
+	object if we've actually optimized something
+	* bytecomp.el (byte-compile-initial-macro-environment):
+	In the labels implementation, work with the byte optimizer, not
+	against it; warn when labels are defined but not used,
+	automatically inline labels that are used only once.
+	* bytecomp.el (byte-recompile-directory):
+	No need to wrap #'byte-compile-report-error in a lambda with
+	#'call-with-condition-handler here. 
+	* bytecomp.el (byte-compile-form):
+	Don't inline compiled-function objects, they're probably labels.
+	* bytecomp.el (byte-compile-funcall):
+	No longer inline lambdas, trust the byte optimizer to have done it
+	properly, even for labels.
+	* cl-extra.el (cl-macroexpand-all):
+	Treat labels established by the byte compiler distinctly from
+	those established by cl-macs.el.
+	* cl-macs.el (cl-do-proclaim):
+	Treat labels established by the byte compiler distinctly from
+	those established by cl-macs.el.
+	* gui.el (make-gui-button):
+	When referring to the #'gui-button-action label, quote it using
+	function, otherwise there's a warning from the byte compiler.
+
 2012-05-05  Aidan Kehoe  <kehoea@parhasard.net>
 
 	Remove some redundant functions; turn other utility functions into

lisp/byte-optimize.el

 	  (error "file \"%s\" didn't define \"%s\"" (nth 1 fn) name))
       (if (symbolp fn)
 	  (byte-compile-inline-expand (cons fn (cdr form)))
-	(if (compiled-function-p fn)
-	    (progn
-	      (fetch-bytecode fn)
-	      (cons (list 'lambda (compiled-function-arglist fn)
-			  (list 'byte-code
-				(compiled-function-instructions fn)
-				(compiled-function-constants fn)
-				(compiled-function-stack-depth fn)))
-		    (cdr form)))
-	  (if (eq (car-safe fn) 'lambda)
-	      (cons fn (cdr form))
-	    ;; Give up on inlining.
-	    form))))))
+	(if (or (eq (car-safe fn) 'lambda) (compiled-function-p fn))
+	    (byte-compile-unfold-lambda (cons fn (cdr form)))
+	  ;; Give up on inlining.
+	  form)))))
 
 ;;; ((lambda ...) ...)
 ;;;
 		(byte-compile-warn
 		 "attempt to open-code %s with too many arguments" name))
 	    form)
-	(setq body (mapcar 'byte-optimize-form body))
+	(setq body (byte-optimize-body body nil))
 	(let ((newform
 	       (if bindings
 		   (cons 'let (cons (nreverse bindings) body))
 	  newform)))))
 
 
+(defun byte-optimize-lambda (form)
+  (let* ((offset 2) (body (nthcdr offset form)))
+    (if (stringp (car body)) (setq body (nthcdr (incf offset) form)))
+    (if (eq 'interactive (car-safe (car body)))
+	(setq body (nthcdr (incf offset) form)))
+    (if (eq body (setq body (byte-optimize-body body nil)))
+        form
+      (nconc (subseq form 0 offset) body))))
+
 ;;; implementing source-level optimizers
 
 (defun byte-optimize-form-code-walker (form for-effect)
 	   (and (nth 1 form)
 		(not for-effect)
 		form))
-	  ((or (compiled-function-p fn)
-	       (eq 'lambda (car-safe fn)))
-	   (byte-compile-unfold-lambda form))
+	  ((eq fn 'function) 
+	   (when (cddr form)
+             (byte-compile-warn "malformed function form: %S" form))
+	   (cond
+            (for-effect nil)
+            ((and (eq (car-safe (cadr form)) 'lambda)
+                  (not (eq (cadr form) (setq tmp (byte-optimize-lambda
+                                                  (cadr form))))))
+             (list fn tmp))
+            (t form)))
+	  ((and (eq 'lambda (car-safe fn))
+                (not (eq form (setq form (byte-compile-unfold-lambda form)))))
+           form)
 	  ((memq fn '(let let*))
 	   ;; recursively enter the optimizer for the bindings and body
 	   ;; of a let or let*.  This for depth-firstness: forms that
 			      (prin1-to-string form))
 	   nil)
 
-	  ((memq fn '(defun defmacro function
-		      condition-case save-window-excursion))
-	   ;; These forms are compiled as constants or by breaking out
-	   ;; all the subexpressions and compiling them separately.
-	   form)
+          ((memq fn '(defun defmacro))
+           (if (eq (setq tmp (cons 'lambda (cddr form)))
+                   (setq tmp (byte-optimize-lambda tmp)))
+               (cons fn (cdr tmp))
+             form))
+
+          ((eq fn 'condition-case)
+           (list* fn (nth 1 form) (byte-optimize-form (nth 2 form) for-effect)
+                  (mapcar #'(lambda (handler)
+                              (cons (car handler)
+                                    (byte-optimize-body (cdr handler)
+                                                        for-effect)))
+                          (cdddr form))))
 
 	  ((eq fn 'unwind-protect)
 	   ;; the "protected" part of an unwind-protect is compiled (and thus
 					    byte-compile-macro-environment))))
 	   (byte-optimize-form form for-effect))
 
+	  ((compiled-function-p fn)
+           (cons fn (mapcar #'byte-optimize-form (cdr form))))
+
 	  ((not (symbolp fn))
-	   (byte-compile-warn "%s is a malformed function" (prin1-to-string fn))
+           (byte-compile-warn "%S is a malformed function" fn)
 	   form)
 
 	  ;; Support compiler macros as in cl.el.
   ;; all-for-effect is true.  Returns a new list of forms.
   (let ((rest forms)
 	(result nil)
+        (modified nil)
 	fe new)
     (while rest
       (setq fe (or all-for-effect (cdr rest)))
       (setq new (and (car rest) (byte-optimize-form (car rest) fe)))
       (if (or new (not fe))
-	  (setq result (cons new result)))
+	  (setq result (cons new result)
+                modified (or modified (not (eq new (car rest)))))
+        (setq modified t))
       (setq rest (cdr rest)))
-    (nreverse result)))
+    (if modified (nreverse result) forms)))
 
 
 ;;; some source-level optimizers
           #'(lambda (form &optional read-only)
               (list wrapper form))))
     (labels
-        . ,#'(lambda (bindings &rest body)
-               (let* ((names (mapcar 'car bindings))
-                      (lambdas (mapcar
-                                (function*
-                                 (lambda ((name . definition))
-                                   (cons 'lambda (cdr (cl-transform-lambda
-                                                       definition name)))))
-                                bindings))
-                      (placeholders
-                       (mapcar #'(lambda (lambda)
-                                   (make-byte-code (second lambda) "\xc0\x87"
-                                                   ;; This list is used for
-                                                   ;; the byte-optimize
-                                                   ;; property, if the
-                                                   ;; function is to be
-                                                   ;; inlined. See
-                                                   ;; cl-do-proclaim.
-                                                   (vector nil) 1))
-                               lambdas))
-                      (byte-compile-macro-environment
-                       (pairlis names (mapcar
-                                       #'(lambda (placeholder)
-                                           `(lambda (&rest cl-labels-args)
-                                              ;; Be careful not to quote
-                                              ;; PLACEHOLDER, otherwise
-                                              ;; byte-optimize-funcall inlines
-                                              ;; it.
-                                              (list* 'funcall ,placeholder
-                                                     cl-labels-args)))
-                                       placeholders)
-                                byte-compile-macro-environment))
-                      (gensym (gensym)))
-                 (labels
-                     ((byte-compile-transform-labels (form names lambdas
-                                                      placeholders)
-                        (let* ((inline
-                                 (mapcan
-                                  #'(lambda (name placeholder lambda)
-                                      (and
-                                       (eq
-                                        (getf (aref
-                                               (compiled-function-constants
-                                                placeholder) 0)
-                                              'byte-optimizer)
-                                        'byte-compile-inline-expand)
-                                       `(((function ,placeholder)
-                                          ,(byte-compile-lambda lambda name)
-                                          (function ,lambda)))))
-                                  names placeholders lambdas))
-                               (compiled
-                                (mapcar* #'byte-compile-lambda 
-                                         (if (not inline)
-                                             lambdas
-                                           ;; See further down for the
-                                          ;; rationale of the sublis calls.
-                                           (sublis (pairlis
-                                                    (mapcar #'cadar inline)
-                                                    (mapcar #'third inline))
-                                                   (sublis
-                                                    (pairlis
-                                                     (mapcar #'car inline)
-                                                     (mapcar #'second inline))
-                                                    lambdas :test #'equal)
-                                                   :test #'eq))
-                                         names))
-                               elt)
-                          (mapc #'(lambda (placeholder function)
-                                    (nsubst function placeholder compiled
-                                            :test #'eq
-                                            :descend-structures t))
-                                placeholders compiled)
-                          (when inline
-                            (dolist (triad inline)
-                              (nsubst (setq elt (elt compiled
-                                                     (position (cadar triad)
-                                                               placeholders)))
-                                      (second triad) compiled :test #'eq
-                                      :descend-structures t)
-                              (setf (second triad) elt))
-                            ;; For inlined labels: first, replace uses of
-                            ;; the placeholder in places where it's not an
-                            ;; evident, explicit funcall (that is, where
-                            ;; it is not to be inlined) with the compiled
-                            ;; function:
-                            (setq form (sublis
-                                        (pairlis (mapcar #'car inline)
-                                                 (mapcar #'second inline))
-                                        form :test #'equal)
-                                  ;; Now replace uses of the placeholder
-                                  ;; where it is an evident funcall with the
-                                  ;; lambda, quoted as a function, to allow
-                                  ;; byte-optimize-funcall to do its
-                                  ;; thing. Note that the lambdas still have
-                                  ;; the placeholders, so there's no risk
-                                  ;; of recursive inlining.
-                                  form (sublis (pairlis
-                                                (mapcar #'cadar inline)
-                                                (mapcar #'third inline))
-                                               form :test #'eq)))
-                          (sublis (pairlis placeholders compiled) form
-                                  :test #'eq))))
-                   (put gensym 'byte-compile
-                        #'(lambda (form)
-                            (let* ((names (cadr (cl-pop2 form)))
-                                   (lambdas (mapcar #'cadr (cdr (pop form))))
-                                   (placeholders (cadr (pop form))))
-                              (byte-compile-body-do-effect
-                               (byte-compile-transform-labels form names
-                                                              lambdas
-                                                              placeholders)))))
-                   (put gensym 'byte-hunk-handler
-                        #'(lambda (form)
-                            (let* ((names (cadr (cl-pop2 form)))
-                                   (lambdas (mapcar #'cadr (cdr (pop form))))
-                                   (placeholders (cadr (pop form))))
-                              (byte-compile-file-form
-                               (cons 'progn
-                                     (byte-compile-transform-labels
-                                      form names lambdas placeholders))))))
-		   (setq body
-			 (cl-macroexpand-all `(,gensym ',names (list ,@lambdas)
-					       ',placeholders ,@body)
-					     byte-compile-macro-environment))
-		   (if (position 'lambda (mapcar #'(lambda (object)
-						     (car-safe (cdr-safe
-								object)))
-						 (cdr (third body)))
-				 :key #'car-safe :test-not #'eq)
-		       ;; #'lexical-let has worked its magic, not all the
-		       ;; lambdas are lambdas. Give up on pre-compiling the
-		       ;; labels.
-		       (setq names (mapcar #'copy-symbol names)
-			     lambdas (cdr (third body))
-			     body (sublis (pairlis placeholders names)
-					  (nthcdr 4 body) :test #'eq)
-			     lambdas (sublis (pairlis placeholders names)
-					     lambdas :test #'eq)
-			     body (cl-macroexpand-all
-				   `(lexical-let
-				     ,names
-				     (setf ,@(mapcan #'list names lambdas))
-				     ,@body)
-				   byte-compile-macro-environment))
-		     body)))))
+        . ,(symbol-macrolet ((wrapper '#:labels))
+             (labels
+                 ((cannot-inline-alist (placeholders lambdas)
+		    (let ((inline
+			    ;; What labels should be inline?
+			    (remove-if-not
+			     #'(lambda (placeholder)
+				 (eq 'byte-compile-inline-expand
+				     (get placeholder
+					  'byte-optimizer)))
+			     placeholders)))
+		      ;; Which of those labels--that should be
+		      ;; inline--reference themeselves, or other labels that
+		      ;; should be inline? Give a an alist mapping them to
+		      ;; their data placeholders.
+		      (mapcan
+		       #'(lambda (placeholder lambda)
+			   (and
+			    (eq 'byte-compile-inline-expand
+				(get placeholder 'byte-optimizer))
+			    (block find
+			      (subst-if nil
+					#'(lambda (tree)
+					    (if (memq tree inline)
+						(return-from find t)))
+					lambda)
+			      nil)
+			    `((,placeholder
+			       . ,(get placeholder
+                                       'byte-compile-data-placeholder)))))
+		       placeholders lambdas)))
+                  (destructure-labels (form for-effect)
+                    (let* ((names (cadr (cl-pop2 form)))
+                           (lambdas (mapcar #'cadr (cdr (pop form))))
+                           (placeholders (cadr (pop form)))
+                           (cannot-inline-alist (cannot-inline-alist
+                                                 placeholders lambdas))
+                           (lambdas (sublis cannot-inline-alist
+                                            lambdas :test #'eq)))
+                      ;; Used specially, note the bindings in our callers.
+                      (setq byte-compile-function-environment
+                            (pairlis
+                             (mapcar #'cdr cannot-inline-alist)
+                             (mapcar #'car cannot-inline-alist)
+                             (pairlis placeholders lambdas
+                                      byte-compile-function-environment)))
+                      (if (memq byte-optimize '(t source))
+                          (setq lambdas
+                                (mapcar #'cadr (mapcar #'byte-optimize-form
+                                                       lambdas))
+                                form (byte-optimize-body form for-effect)))
+                      (values placeholders lambdas names form)))
+                  (warn-about-unused-labels (names placeholders)
+                    (when (memq 'unused-vars byte-compile-warnings)
+                      (loop
+                        for placeholder in placeholders
+                        for name in names
+                        if (eql 0 (+ (get placeholder
+                                          'byte-compile-label-calls 0)
+                                     (get (get placeholder
+                                               'byte-compile-data-placeholder
+                                               '#:no-such-data-placeholder)
+                                          'byte-compile-label-calls 0)))
+                        do (byte-compile-warn
+                            "label %s bound but not referenced" name))))
+                  (byte-compile-transform-labels (form names lambdas
+                                                  placeholders)
+                    (let ((compiled
+                           (mapcar* #'byte-compile-lambda lambdas names)))
+                      (warn-about-unused-labels names placeholders)
+                      (mapc #'(lambda (placeholder function)
+                                (nsubst function placeholder compiled
+                                        :test #'eq
+                                        :descend-structures t)
+                                (nsubst function
+                                        (get placeholder
+                                             'byte-compile-data-placeholder)
+                                        compiled :test #'eq
+                                        :descend-structures t))
+                            placeholders compiled)
+                      (sublis (pairlis
+                               placeholders compiled
+                               (pairlis
+                                (mapcar*
+                                 #'get placeholders
+                                 (load-time-value
+                                  (let ((list
+                                         (list
+                                          'byte-compile-data-placeholder)))
+                                    (nconc list list))))
+                                compiled))
+                              form :test #'eq))))
+               (put wrapper 'byte-compile
+                    #'(lambda (form)
+                        (let ((byte-compile-function-environment
+                               byte-compile-function-environment))
+                          (multiple-value-bind
+                              (placeholders lambdas names form)
+                              (destructure-labels form for-effect)
+                            (byte-compile-body-do-effect
+                             (byte-compile-transform-labels form names
+                                                            lambdas
+                                                            placeholders))))))
+               (put wrapper 'byte-hunk-handler
+                    #'(lambda (form)
+                        (let ((byte-compile-function-environment
+                               byte-compile-function-environment))
+                          (multiple-value-bind
+                              (placeholders lambdas names form)
+                              (destructure-labels form t)
+                            (byte-compile-file-form
+                             (cons 'progn
+                                   (byte-compile-transform-labels
+                                    form names lambdas placeholders)))))))
+	       (put wrapper 'cl-compiler-macro
+		    ;; This is only used when optimizing code.
+		    #'(lambda (form &rest ignore)
+                        (let ((byte-compile-function-environment
+                               byte-compile-function-environment)
+                              byte-optimize-form retry)
+                          (multiple-value-bind
+                              (placeholders lambdas)
+                              (destructure-labels form for-effect)
+                            ;; Optimize most of the form, in passing
+                            ;; expanding macros.
+                            (setq byte-optimize-form
+                                  (mapcar #'byte-optimize-form
+                                          (list* (nth 1 form) `(list ,@lambdas)
+                                                 (cdddr form))))
+                            ;; It may be reasonable to inline any labels
+                            ;; used only once.
+                            (dolist (placeholder placeholders)
+                              (and 
+                               (not (eq 'byte-compile-inline-expand
+                                        (get placeholder 'byte-optimizer)))
+                               (eql 0 (get (get placeholder
+                                                'byte-compile-data-placeholder
+                                                '#:no-such-data-placeholder)
+                                           'byte-compile-label-calls 0))
+                               (eql 1 (get placeholder
+                                           'byte-compile-label-calls 0))
+                               (progn
+				 (byte-compile-log
+				  "label %s is used only once, inlining it"
+				  placeholder)
+				 (setq retry t)
+				 (cl-do-proclaim `(inline ,placeholder) t))))
+                            (when retry
+                              (multiple-value-setq
+                                  (placeholders lambdas)
+                                (destructure-labels form for-effect))
+                              (setq byte-optimize-form
+                                    (mapcar #'byte-optimize-form
+                                            (list* (nth 1 form)
+                                                   `(list ,@lambdas)
+                                                   (cdddr form)))))
+                            (if (equal (cdr form) byte-optimize-form)
+                                form
+                              (cons (car form) byte-optimize-form)))))))
+             #'(lambda (bindings &rest body)
+                 (let* ((names (mapcar 'car bindings))
+                        (lambdas (mapcar
+                                  (function*
+                                   (lambda ((name . definition))
+                                     `#'(lambda ,@(cdr (cl-transform-lambda
+                                                        definition name)))))
+                                  bindings))
+                        (placeholders (mapcar #'copy-symbol names))
+                        (byte-compile-macro-environment
+                         (pairlis names
+                                  (mapcar
+                                   #'(lambda (placeholder)
+                                       `(lambda (&rest byte-compile-labels-args)
+                                          (put
+                                           ',placeholder
+                                           'byte-compile-label-calls
+                                           (1+ (get ',placeholder
+                                                    'byte-compile-label-calls
+                                                    0)))
+                                          (cons ',placeholder
+                                                byte-compile-labels-args)))
+                                   placeholders)
+                                  byte-compile-macro-environment)))
+                   ;; Tell the macroexpansion code what symbol to use when
+                   ;; expanding #'FUNCTION-NAME:
+                   (mapc #'put placeholders
+                         (load-time-value
+                          (let ((list (list 'byte-compile-data-placeholder)))
+                            (nconc list list)))
+                         (mapcar #'copy-symbol names))
+                   (setq body
+                         (cl-macroexpand-all
+                          `(,wrapper ',names (list ,@lambdas) ',placeholders
+                                      ,@body)
+                          byte-compile-macro-environment))
+                   (if (position 'lambda (mapcar #'(lambda (object)
+                                                     (car-safe (cdr-safe
+                                                                object)))
+                                                 (cdr (third body)))
+                                 :key #'car-safe :test-not #'eq)
+                       ;; #'lexical-let has worked its magic, not all the
+                       ;; lambdas are lambdas. Give up on pre-compiling the
+                       ;; labels.
+                       (setq names (mapcar #'copy-symbol names)
+                             lambdas (cdr (third body))
+                             body (sublis (pairlis placeholders names)
+                                          (nthcdr 4 body) :test #'eq)
+                             lambdas (sublis (pairlis placeholders names)
+                                             lambdas :test #'eq)
+                             body (cl-macroexpand-all
+                                   `(lexical-let
+                                     ,names
+                                     (setf ,@(mapcan #'list names lambdas))
+                                     ,@body)
+                                   byte-compile-macro-environment))
+                     body)))))
     (flet .
       ,#'(lambda (bindings &rest body)
            (let* ((names (mapcar 'car bindings))
 
        (unwind-protect
 	   (call-with-condition-handler
-	       #'(lambda (error-info)
-		   (byte-compile-report-error error-info))
+               #'byte-compile-report-error
 	       #'(lambda ()
 		   (progn ,@body)))
 	 ;; Always set point in log to start of interesting output.
 	     (if (memq 'callargs byte-compile-warnings)
 		 (byte-compile-callargs-warn form))
 	     (byte-compile-normal-call form))))
-	((and (or (compiled-function-p (car form))
-		  (eq (car-safe (car form)) 'lambda))
+	((and (eq (car-safe (car form)) 'lambda)
 	      ;; if the form comes out the same way it went in, that's
 	      ;; because it was malformed, and we couldn't unfold it.
 	      (not (eq form (setq form (byte-compile-unfold-lambda form)))))
 (map nil
      (function*
       (lambda ((function . nargs))
-	;; Document that the car of OBJECT, a symbol, describes a function
-	;; taking keyword arguments from the argument index described by
-	;; the cdr of OBJECT.
+	;; Document that FUNCTION, a symbol, describes a function taking
+	;; keyword arguments from the argument index described by NARGS.
 	(put function 'byte-compile-keyword-start nargs)))
      '((adjoin . 3) (assoc* . 3) (assoc-if . 3) (assoc-if-not . 3)
        (count . 3) (count-if . 3) (count-if-not . 3) (define-behavior . 3)
            (byte-compile-constp (second form)))
       (byte-compile-callargs-warn (cons (cl-const-expr-val (second form))
                                         (nthcdr 2 form))))
-  (if (and byte-optimize
-           (eq 'function (car-safe (cadr form)))
-           (eq 'lambda (car-safe (cadadr form)))
-	    (or
-	     (not (eq (setq form (cons (cadadr form) (cddr form)))
-		      (setq form (byte-compile-unfold-lambda form))))
-	     (prog1 nil (setq form `(funcall #',(car form) ,@(cdr form))))))
-      ;; The byte-compile part of the #'labels implementation, above,
-      ;; happens after macroexpansion and after the source optimizer has
-      ;; done its thing. When labels are to be made inline we can have code
-      ;; that looks like (funcall #'(lambda ...) ...), when the code that
-      ;; the optimizer saw looked like (funcall #<compiled-function ...>
-      ;; ...).
-      ;;
-      ;; So, the optimizer doesn't have the opportunity to transform the
-      ;; former to (let (...) ...), and it's reasonable to do that here (since
-      ;; the labels implementation doesn't change other code that would need
-      ;; running through the optimizer; the lambda itself has already been
-      ;; through the optimizer).
-      ;;
-      ;; Equally reasonable, and conceptually a bit clearer, would be to do
-      ;; the transformation to (funcall #'(lambda ...) ...) in the
-      ;; byte-optimizer, breaking most of the #'sublis calls out of the
-      ;; byte-compile method.
-      (byte-compile-form form)
-    (mapc 'byte-compile-form (cdr form))
-    (byte-compile-out 'byte-call (length (cdr (cdr form))))))
-
+  (mapc 'byte-compile-form (cdr form))
+  (byte-compile-out 'byte-call (length (cdr (cdr form)))))
 
 (defun byte-compile-let (form)
   ;; First compute the binding values in the old scope.
            ;; This is a bit of a hack; special-case symbols with bindings as
            ;; labels.
 	   (let ((found (cdr (assq (cadr form) env))))
-	     (if (and (consp found) (eq (nth 1 (nth 1 found)) 'cl-labels-args))
-                 (if (consp (nth 2 (nth 2 found)))
-                     ;; It's a cons; this is the implementation of
-                     ;; labels in cl-macs.el.
-                     (cl-macroexpand-all (nth 1 (nth 2 (nth 2 found))) env)
-                   ;; It's an atom, almost certainly a compiled function;
-                   ;; we're using the implementation of labels in
-                   ;; bytecomp.el. Quote it with FUNCTION so that code can
-                   ;; tell uses as data apart from the uses with funcall,
-                   ;; where it's unquoted. #### We should warn if (car form)
-                   ;; above is quote, rather than function.
-                   (list 'function (nth 2 (nth 2 found))))
-	       form))))
+	     (cond
+              ((and (consp found) (eq (nth 1 (nth 1 found)) 'cl-labels-args))
+               ;; This is the implementation of labels in cl-macs.el.
+               (cl-macroexpand-all (nth 1 (nth 2 (nth 2 found))) env))
+              ((and (consp found) (eq (nth 1 (nth 1 found))
+                                      'byte-compile-labels-args))
+               ;; We're using the implementation of labels in
+               ;; bytecomp.el. Quote its data-placeholder with FUNCTION so
+               ;; that code can tell uses as data apart from the uses with
+               ;; funcall.
+               (unless (eq 'function (car form))
+                 (byte-compile-warn
+                  "deprecated: '%s, use #'%s instead to quote it as a function"
+                  (cadr form) (cadr form)))
+               (setq found (get (nth 1 (nth 1 (nth 3 found)))
+                                'byte-compile-data-placeholder))
+               (put found 'byte-compile-label-calls
+                    (1+ (get found 'byte-compile-label-calls 0)))
+               (list 'function found))
+              (t form)))))
 	((memq (car form) '(defun defmacro))
 	 (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
 	((and (eq (car form) 'progn) (not (cddr form)))
 		    byte-compile-bound-variables))))
 
 	((eq (car-safe spec) 'inline)
-	 (while (setq spec (cdr spec))
-	   (let ((assq (cdr (assq (car spec) byte-compile-macro-environment))))
-	     (if (and (consp assq) (eq (nth 1 (nth 1 assq)) 'cl-labels-args)
-		      (atom (setq assq (nth 2 (nth 2 assq)))))
-		 ;; It's a label, and we're using the labels
-		 ;; implementation in bytecomp.el. Tell the compiler
-		 ;; to inline it, don't mark the symbol to be inlined
-		 ;; globally.
-		 (setf (getf (aref (compiled-function-constants assq) 0)
-                             'byte-optimizer)
-                       'byte-compile-inline-expand)
-	       (or (memq (get (car spec) 'byte-optimizer)
-			 '(nil byte-compile-inline-expand))
-		   (error
-		    "%s already has a byte-optimizer, can't make it inline"
-		    (car spec)))
-	       (put (car spec) 'byte-optimizer 'byte-compile-inline-expand)))))
+         (while (setq spec (cdr spec))
+           (let* ((assq (cdr (assq (car spec)
+                                   byte-compile-macro-environment)))
+                  (symbol (if (and (consp assq)
+                                   (eq (nth 1 (nth 1 assq))
+                                       'byte-compile-labels-args))
+                              ;; It's a label, and we're using the labels
+                              ;; implementation in bytecomp.el. Tell the
+                              ;; compiler to inline it, don't mark the
+                              ;; symbol to be inlined globally.
+                              (nth 1 (nth 1 (nth 3 assq)))
+                            (car spec))))
+             (or (memq (get symbol 'byte-optimizer)
+                       '(nil byte-compile-inline-expand))
+                 (error
+                  "%s already has a byte-optimizer, can't make it inline"
+                  symbol))
+             (put symbol 'byte-optimizer 'byte-compile-inline-expand))))
 	((eq (car-safe spec) 'notinline)
 	 (while (setq spec (cdr spec))
-	   (let ((assq (cdr (assq (car spec) byte-compile-macro-environment))))
-	     (if (and (consp assq) (eq (nth 1 (nth 1 assq)) 'cl-labels-args)
-		      (atom (setq assq (nth 2 (nth 2 assq)))))
-		 ;; It's a label, and we're using the labels
-		 ;; implementation in bytecomp.el. Tell the compiler
-		 ;; not to inline it.
-                 (if (eq 'byte-compile-inline-expand
-                         (getf (aref (compiled-function-constants assq) 0)
-                               'byte-optimizer))
-                     (remf (aref (compiled-function-constants assq) 0)
-                           'byte-optimizer))
-	       (if (eq (get (car spec) 'byte-optimizer)
-		       'byte-compile-inline-expand)
-		   (put (car spec) 'byte-optimizer nil))))))
+           (let* ((assq (cdr (assq (car spec)
+                                   byte-compile-macro-environment)))
+                  (symbol (if (and (consp assq)
+                                   (eq (nth 1 (nth 1 assq))
+                                       'byte-compile-labels-args))
+                              ;; It's a label, and we're using the labels
+                              ;; implementation in bytecomp.el. Tell the
+                              ;; compiler not to inline it, don't mark the
+                              ;; symbol to be notinline globally.
+                              (nth 1 (nth 1 (nth 3 assq)))
+                            (car spec))))
+             (if (eq (get symbol 'byte-optimizer)
+                     'byte-compile-inline-expand)
+                 (put symbol 'byte-optimizer nil)))))
 	((eq (car-safe spec) 'optimize)
 	 (let ((speed (assq (nth 1 (assq 'speed (cdr spec)))
 			    '((0 . nil) (1 . t) (2 . t) (3 . t))))
     (vector 'button
             :descriptor string
             :face 'gui-button-face
-            :callback-ex `(lambda (image-instance event)
-                            (gui-button-action image-instance
-                                               (quote ,action)
-                                               (quote ,user-data))))))
+            :callback-ex
+            `(lambda (image-instance event)
+               (funcall ,#'gui-button-action image-instance ',action
+                        ',user-data)))))
 
 (defun insert-gui-button (button &optional pos buffer)
   "Insert GUI button BUTTON at POS in BUFFER."