xemacs-beta: lisp/bytecomp.el comparison

comparison lisp/bytecomp.el @ 5656:e9c3fe82127d

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.

author	Aidan Kehoe <kehoea@parhasard.net>
date	Sat, 05 May 2012 20:48:24 +0100
parents	cc6f0266bc36
children	b3a2bff825c8

comparison

equal deleted inserted replaced

-:b7ae5f44b950
+:e9c3fe82127d
 t 'file))
 (byte-compile-form `(symbol-value ',gensym) nil))))
 #'(lambda (form &optional read-only)
 (list wrapper form))))
 (labels
-. ,#'(lambda (bindings &rest body)
+. ,(symbol-macrolet ((wrapper '#:labels))
-(let* ((names (mapcar 'car bindings))
+(labels
-(lambdas (mapcar
+((cannot-inline-alist (placeholders lambdas)
-(function*
+		    (let ((inline
-(lambda ((name . definition))
+			    ;; What labels should be inline?
-(cons 'lambda (cdr (cl-transform-lambda
+			    (remove-if-not
-definition name)))))
+			     #'(lambda (placeholder)
-bindings))
+				 (eq 'byte-compile-inline-expand
-(placeholders
+				     (get placeholder
-(mapcar #'(lambda (lambda)
+					  'byte-optimizer)))
-(make-byte-code (second lambda) "\xc0\x87"
+			     placeholders)))
-;; This list is used for
+		      ;; Which of those labels--that should be
-;; the byte-optimize
+		      ;; inline--reference themeselves, or other labels that
-;; property, if the
+		      ;; should be inline? Give a an alist mapping them to
-;; function is to be
+		      ;; their data placeholders.
-;; inlined. See
+		      (mapcan
-;; cl-do-proclaim.
+		       #'(lambda (placeholder lambda)
-(vector nil) 1))
+			   (and
-lambdas))
+			    (eq 'byte-compile-inline-expand
-(byte-compile-macro-environment
+				(get placeholder 'byte-optimizer))
-(pairlis names (mapcar
+			    (block find
-#'(lambda (placeholder)
+			      (subst-if nil
-`(lambda (&rest cl-labels-args)
+					#'(lambda (tree)
-;; Be careful not to quote
+					    (if (memq tree inline)
-;; PLACEHOLDER, otherwise
+						(return-from find t)))
-;; byte-optimize-funcall inlines
+					lambda)
-;; it.
+			      nil)
-(list* 'funcall ,placeholder
+			    `((,placeholder
-cl-labels-args)))
+			       . ,(get placeholder
-placeholders)
+'byte-compile-data-placeholder)))))
-byte-compile-macro-environment))
+		       placeholders lambdas)))
-(gensym (gensym)))
+(destructure-labels (form for-effect)
-(labels
+(let* ((names (cadr (cl-pop2 form)))
-((byte-compile-transform-labels (form names lambdas
+(lambdas (mapcar #'cadr (cdr (pop form))))
-placeholders)
+(placeholders (cadr (pop form)))
-(let* ((inline
+(cannot-inline-alist (cannot-inline-alist
-(mapcan
+placeholders lambdas))
-#'(lambda (name placeholder lambda)
+(lambdas (sublis cannot-inline-alist
-(and
+lambdas :test #'eq)))
-(eq
+;; Used specially, note the bindings in our callers.
-(getf (aref
+(setq byte-compile-function-environment
-(compiled-function-constants
+(pairlis
-placeholder) 0)
+(mapcar #'cdr cannot-inline-alist)
-'byte-optimizer)
+(mapcar #'car cannot-inline-alist)
-'byte-compile-inline-expand)
+(pairlis placeholders lambdas
-`(((function ,placeholder)
+byte-compile-function-environment)))
-,(byte-compile-lambda lambda name)
+(if (memq byte-optimize '(t source))
-(function ,lambda)))))
+(setq lambdas
-names placeholders lambdas))
+(mapcar #'cadr (mapcar #'byte-optimize-form
-(compiled
+lambdas))
-(mapcar* #'byte-compile-lambda
+form (byte-optimize-body form for-effect)))
-(if (not inline)
+(values placeholders lambdas names form)))
-lambdas
+(warn-about-unused-labels (names placeholders)
-;; See further down for the
+(when (memq 'unused-vars byte-compile-warnings)
-;; rationale of the sublis calls.
+(loop
-(sublis (pairlis
+for placeholder in placeholders
-(mapcar #'cadar inline)
+for name in names
-(mapcar #'third inline))
+if (eql 0 (+ (get placeholder
-(sublis
+'byte-compile-label-calls 0)
-(pairlis
+(get (get placeholder
-(mapcar #'car inline)
+'byte-compile-data-placeholder
-(mapcar #'second inline))
+'#:no-such-data-placeholder)
-lambdas :test #'equal)
+'byte-compile-label-calls 0)))
-:test #'eq))
+do (byte-compile-warn
-names))
+"label %s bound but not referenced" name))))
-elt)
+(byte-compile-transform-labels (form names lambdas
-(mapc #'(lambda (placeholder function)
+placeholders)
-(nsubst function placeholder compiled
+(let ((compiled
-:test #'eq
+(mapcar* #'byte-compile-lambda lambdas names)))
-:descend-structures t))
+(warn-about-unused-labels names placeholders)
-placeholders compiled)
+(mapc #'(lambda (placeholder function)
-(when inline
+(nsubst function placeholder compiled
-(dolist (triad inline)
+:test #'eq
-(nsubst (setq elt (elt compiled
+:descend-structures t)
-(position (cadar triad)
+(nsubst function
-placeholders)))
+(get placeholder
-(second triad) compiled :test #'eq
+'byte-compile-data-placeholder)
-:descend-structures t)
+compiled :test #'eq
-(setf (second triad) elt))
+:descend-structures t))
-;; For inlined labels: first, replace uses of
+placeholders compiled)
-;; the placeholder in places where it's not an
+(sublis (pairlis
-;; evident, explicit funcall (that is, where
+placeholders compiled
-;; it is not to be inlined) with the compiled
+(pairlis
-;; function:
+(mapcar*
-(setq form (sublis
+#'get placeholders
-(pairlis (mapcar #'car inline)
+(load-time-value
-(mapcar #'second inline))
+(let ((list
-form :test #'equal)
+(list
-;; Now replace uses of the placeholder
+'byte-compile-data-placeholder)))
-;; where it is an evident funcall with the
+(nconc list list))))
-;; lambda, quoted as a function, to allow
+compiled))
-;; byte-optimize-funcall to do its
+form :test #'eq))))
-;; thing. Note that the lambdas still have
+(put wrapper 'byte-compile
-;; the placeholders, so there's no risk
+#'(lambda (form)
-;; of recursive inlining.
+(let ((byte-compile-function-environment
-form (sublis (pairlis
+byte-compile-function-environment))
-(mapcar #'cadar inline)
+(multiple-value-bind
-(mapcar #'third inline))
+(placeholders lambdas names form)
-form :test #'eq)))
+(destructure-labels form for-effect)
-(sublis (pairlis placeholders compiled) form
+(byte-compile-body-do-effect
-:test #'eq))))
+(byte-compile-transform-labels form names
-(put gensym 'byte-compile
+lambdas
-#'(lambda (form)
+placeholders))))))
-(let* ((names (cadr (cl-pop2 form)))
+(put wrapper 'byte-hunk-handler
-(lambdas (mapcar #'cadr (cdr (pop form))))
+#'(lambda (form)
-(placeholders (cadr (pop form))))
+(let ((byte-compile-function-environment
-(byte-compile-body-do-effect
+byte-compile-function-environment))
-(byte-compile-transform-labels form names
+(multiple-value-bind
-lambdas
+(placeholders lambdas names form)
-placeholders)))))
+(destructure-labels form t)
-(put gensym 'byte-hunk-handler
+(byte-compile-file-form
-#'(lambda (form)
+(cons 'progn
-(let* ((names (cadr (cl-pop2 form)))
+(byte-compile-transform-labels
-(lambdas (mapcar #'cadr (cdr (pop form))))
+form names lambdas placeholders)))))))
-(placeholders (cadr (pop form))))
+	       (put wrapper 'cl-compiler-macro
-(byte-compile-file-form
+		    ;; This is only used when optimizing code.
-(cons 'progn
+		    #'(lambda (form &rest ignore)
-(byte-compile-transform-labels
+(let ((byte-compile-function-environment
-form names lambdas placeholders))))))
+byte-compile-function-environment)
-		   (setq body
+byte-optimize-form retry)
-			 (cl-macroexpand-all `(,gensym ',names (list ,@lambdas)
+(multiple-value-bind
-					       ',placeholders ,@body)
+(placeholders lambdas)
-					     byte-compile-macro-environment))
+(destructure-labels form for-effect)
-		   (if (position 'lambda (mapcar #'(lambda (object)
+;; Optimize most of the form, in passing
-						     (car-safe (cdr-safe
+;; expanding macros.
-								object)))
+(setq byte-optimize-form
-						 (cdr (third body)))
+(mapcar #'byte-optimize-form
-				 :key #'car-safe :test-not #'eq)
+(list* (nth 1 form) `(list ,@lambdas)
-		       ;; #'lexical-let has worked its magic, not all the
+(cdddr form))))
-		       ;; lambdas are lambdas. Give up on pre-compiling the
+;; It may be reasonable to inline any labels
-		       ;; labels.
+;; used only once.
-		       (setq names (mapcar #'copy-symbol names)
+(dolist (placeholder placeholders)
-			     lambdas (cdr (third body))
+(and
-			     body (sublis (pairlis placeholders names)
+(not (eq 'byte-compile-inline-expand
-					  (nthcdr 4 body) :test #'eq)
+(get placeholder 'byte-optimizer)))
-			     lambdas (sublis (pairlis placeholders names)
+(eql 0 (get (get placeholder
-					     lambdas :test #'eq)
+'byte-compile-data-placeholder
-			     body (cl-macroexpand-all
+'#:no-such-data-placeholder)
-				   `(lexical-let
+'byte-compile-label-calls 0))
-				     ,names
+(eql 1 (get placeholder
-				     (setf ,@(mapcan #'list names lambdas))
+'byte-compile-label-calls 0))
-				     ,@body)
+(progn
-				   byte-compile-macro-environment))
+				 (byte-compile-log
-		     body)))))
+				  "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))
 (lambdas (mapcar
 (function*
 		byte-compile-warnings-beginning
 	      (point-max byte-compile-log-buffer))))
 (unwind-protect
 	   (call-with-condition-handler
-	       #'(lambda (error-info)
+#'byte-compile-report-error
-		   (byte-compile-report-error error-info))
 	       #'(lambda ()
 		   (progn ,@body)))
 	 ;; Always set point in log to start of interesting output.
 	 (with-current-buffer byte-compile-log-buffer
 	   (let ((show-begin
 	   (if handler
 	       (funcall handler form)
 	     (if (memq 'callargs byte-compile-warnings)
 		 (byte-compile-callargs-warn form))
 	     (byte-compile-normal-call form))))
-	((and (or (compiled-function-p (car form))
+	((and (eq (car-safe (car form)) 'lambda)
-		  (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)))))
 	 (byte-compile-form form for-effect)
 	 (setq for-effect nil))
 ;; cl-parsing-keywords macro, but the below list does.
 (map nil
 (function*
 (lambda ((function . nargs))
-	;; Document that the car of OBJECT, a symbol, describes a function
+	;; Document that FUNCTION, a symbol, describes a function taking
-	;; taking keyword arguments from the argument index described by
+	;; keyword arguments from the argument index described by NARGS.
-	;; the cdr of OBJECT.
 	(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)
 (define-behavior-group . 2) (delete* . 3) (delete-duplicates . 2)
 (delete-if . 3) (delete-if-not . 3) (fill . 3) (find . 3) (find-if . 3)
 (defun byte-compile-funcall (form)
 (if (and (memq 'callargs byte-compile-warnings)
 (byte-compile-constp (second form)))
 (byte-compile-callargs-warn (cons (cl-const-expr-val (second form))
 (nthcdr 2 form))))
-(if (and byte-optimize
+(mapc 'byte-compile-form (cdr form))
-(eq 'function (car-safe (cadr form)))
+(byte-compile-out 'byte-call (length (cdr (cdr 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))))))
 (defun byte-compile-let (form)
 ;; First compute the binding values in the old scope.
 (let ((varlist (car (cdr form))))
 (while varlist

Mercurial > hg > xemacs-beta

comparison lisp/bytecomp.el @ 5656:e9c3fe82127d