xemacs-beta: lisp/byte-optimize.el comparison

comparison lisp/byte-optimize.el @ 380:8626e4521993 r21-2-5

Import from CVS: tag r21-2-5

author	cvs
date	Mon, 13 Aug 2007 11:07:10 +0200
parents	cc15677e0335
children	74fd4e045ea6

comparison

equal deleted inserted replaced

-:76b7d63099ad
+:8626e4521993
-;;; byte-opt.el --- the optimization passes of the emacs-lisp byte compiler.
+;;; byte-optimize.el --- the optimization passes of the emacs-lisp byte compiler.
 ;;; Copyright (c) 1991, 1994 Free Software Foundation, Inc.
 ;; Author: Jamie Zawinski <jwz@netscape.com>
 ;;	Hallvard Furuseth <hbf@ulrik.uio.no>
 ;; to get it there.
 ;;
 ;; TO DO:
 ;;
-;; (apply '(lambda (x &rest y) ...) 1 (foo))
+;; (apply #'(lambda (x &rest y) ...) 1 (foo))
 ;;
 ;; maintain a list of functions known not to access any global variables
 ;; (actually, give them a 'dynamically-safe property) and then
 ;;   (let ( v1 v2 ... vM vN ) <...dynamically-safe...> )  ==>
 ;;   (let ( v1 v2 ... vM ) vN <...dynamically-safe...> )
 ;; Since this would be a file-local optimization, there would be no way to
 ;; modify the interpreter to obey this (unless the loader was hacked
 ;; in some grody way, but that's a really bad idea.)
 ;;
 ;; HA!  RMS removed the following paragraph from his version of
-;; byte-opt.el.
+;; byte-optimize.el.
 ;;
 ;; Really the Right Thing is to make lexical scope the default across
 ;; the board, in the interpreter and compiler, and just FIX all of
 ;; the code that relies on dynamic scope of non-defvarred variables.
 ;; Other things to consider:
 ;; Associative math should recognize subcalls to identical function:
-;;(disassemble (lambda (x) (+ (+ (foo) 1) (+ (bar) 2))))
+;;(disassemble #'(lambda (x) (+ (+ (foo) 1) (+ (bar) 2))))
 ;; This should generate the same as (1+ x) and (1- x)
-;;(disassemble (lambda (x) (cons (+ x 1) (- x 1))))
+;;(disassemble #'(lambda (x) (cons (+ x 1) (- x 1))))
 ;; An awful lot of functions always return a non-nil value.  If they're
 ;; error free also they may act as true-constants.
-;;(disassemble (lambda (x) (and (point) (foo))))
+;;(disassemble #'(lambda (x) (and (point) (foo))))
 ;; When
 ;;   - all but one arguments to a function are constant
 ;;   - the non-constant argument is an if-expression (cond-expression?)
 ;; then the outer function can be distributed.  If the guarding
 ;; condition is side-effect-free [assignment-free] then the other
 ;; arguments may be any expressions.  Since, however, the code size
 ;; can increase this way they should be "simple".  Compare:
-;;(disassemble (lambda (x) (eq (if (point) 'a 'b) 'c)))
+;;(disassemble #'(lambda (x) (eq (if (point) 'a 'b) 'c)))
-;;(disassemble (lambda (x) (if (point) (eq 'a 'c) (eq 'b 'c))))
+;;(disassemble #'(lambda (x) (if (point) (eq 'a 'c) (eq 'b 'c))))
 ;; (car (cons A B)) -> (progn B A)
-;;(disassemble (lambda (x) (car (cons (foo) 42))))
+;;(disassemble #'(lambda (x) (car (cons (foo) 42))))
 ;; (cdr (cons A B)) -> (progn A B)
-;;(disassemble (lambda (x) (cdr (cons 42 (foo)))))
+;;(disassemble #'(lambda (x) (cdr (cons 42 (foo)))))
 ;; (car (list A B ...)) -> (progn B ... A)
-;;(disassemble (lambda (x) (car (list (foo) 42 (bar)))))
+;;(disassemble #'(lambda (x) (car (list (foo) 42 (bar)))))
 ;; (cdr (list A B ...)) -> (progn A (list B ...))
-;;(disassemble (lambda (x) (cdr (list 42 (foo) (bar)))))
+;;(disassemble #'(lambda (x) (cdr (list 42 (foo) (bar)))))
 ;;; Code:
 (require 'byte-compile "bytecomp")
 (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."))
 (byte-compile-log-1
 (apply 'format format
-(let (c a)
+	  (let (c a)
-(mapcar '(lambda (arg)
+	    (mapcar
-		  (if (not (consp arg))
+	     #'(lambda (arg)
-		      (if (and (symbolp arg)
+		 (if (not (consp arg))
-			       (string-match "^byte-" (symbol-name arg)))
+		     (if (and (symbolp arg)
-			  (intern (substring (symbol-name arg) 5))
+			      (string-match "^byte-" (symbol-name arg)))
-			arg)
+			 (intern (substring (symbol-name arg) 5))
-		    (if (integerp (setq c (car arg)))
+		       arg)
-			(error "non-symbolic byte-op %s" c))
+		   (if (integerp (setq c (car arg)))
-		    (if (eq c 'TAG)
+		       (error "non-symbolic byte-op %s" c))
-			(setq c arg)
+		   (if (eq c 'TAG)
-		      (setq a (cond ((memq c byte-goto-ops)
+		       (setq c arg)
-				     (car (cdr (cdr arg))))
+		     (setq a (cond ((memq c byte-goto-ops)
-				    ((memq c byte-constref-ops)
+				    (car (cdr (cdr arg))))
-				     (car (cdr arg)))
+				   ((memq c byte-constref-ops)
-				    (t (cdr arg))))
+				    (car (cdr arg)))
-		      (setq c (symbol-name c))
+				   (t (cdr arg))))
-		      (if (string-match "^byte-." c)
+		     (setq c (symbol-name c))
-			  (setq c (intern (substring c 5)))))
+		     (if (string-match "^byte-." c)
-		    (if (eq c 'constant) (setq c 'const))
+			 (setq c (intern (substring c 5)))))
-		    (if (and (eq (cdr arg) 0)
+		   (if (eq c 'constant) (setq c 'const))
-			     (not (memq c '(unbind call const))))
+		   (if (and (eq (cdr arg) 0)
-			c
+			    (not (memq c '(unbind call const))))
-		      (format "(%s %s)" c a))))
+		       c
-	       args)))))
+		     (format "(%s %s)" c a))))
+	     args)))))
 (defmacro byte-compile-log-lap (format-string &rest args)
 (list 'and
 	'(memq byte-optimize-log '(t byte))
 	(cons 'byte-compile-log-lap-1
 (put 'inline 'byte-optimizer 'byte-optimize-inline-handler)
 (defun byte-optimize-inline-handler (form)
 "byte-optimize-handler for the `inline' special-form."
-(cons 'progn
+(cons
-	(mapcar
+'progn
-	 '(lambda (sexp)
+(mapcar
-	    (let ((fn (car-safe sexp)))
+#'(lambda (sexp)
-	      (if (and (symbolp fn)
+	(let ((fn (car-safe sexp)))
-		    (or (cdr (assq fn byte-compile-function-environment))
+	  (if (and (symbolp fn)
-		      (and (fboundp fn)
+		   (or (cdr (assq fn byte-compile-function-environment))
-			(not (or (cdr (assq fn byte-compile-macro-environment))
+		       (and (fboundp fn)
-				 (and (consp (setq fn (symbol-function fn)))
+			    (not (or (cdr (assq fn byte-compile-macro-environment))
-				      (eq (car fn) 'macro))
+				     (and (consp (setq fn (symbol-function fn)))
-				 (subrp fn))))))
+					  (eq (car fn) 'macro))
-		  (byte-compile-inline-expand sexp)
+				     (subrp fn))))))
-		sexp)))
+	      (byte-compile-inline-expand sexp)
-	 (cdr form))))
+	    sexp)))
+(cdr form))))
 ;; Splice the given lap code into the current instruction stream.
 ;; If it has any labels in it, you're responsible for making sure there
 ;; are no collisions, and that byte-compile-tag-number is reasonable
 	   ;; recursively enter the optimizer for the bindings and body
 	   ;; of a let or let*.  This for depth-firstness: forms that
 	   ;; are more deeply nested are optimized first.
 	   (cons fn
 	     (cons
-	      (mapcar '(lambda (binding)
+	      (mapcar
-			 (if (symbolp binding)
+	       #'(lambda (binding)
-			     binding
+		   (if (symbolp binding)
-			   (if (cdr (cdr binding))
+		       binding
-			       (byte-compile-warn "malformed let binding: %s"
+		     (if (cdr (cdr binding))
-						  (prin1-to-string binding)))
+			 (byte-compile-warn "malformed let binding: %s"
-			   (list (car binding)
+					    (prin1-to-string binding)))
-				 (byte-optimize-form (nth 1 binding) nil))))
+		     (list (car binding)
-		      (nth 1 form))
+			   (byte-optimize-form (nth 1 binding) nil))))
+	       (nth 1 form))
 	      (byte-optimize-body (cdr (cdr form)) for-effect))))
 	  ((eq fn 'cond)
 	   (cons fn
-		 (mapcar '(lambda (clause)
+		 (mapcar
-			    (if (consp clause)
+		  #'(lambda (clause)
-				(cons
+		      (if (consp clause)
-				 (byte-optimize-form (car clause) nil)
+			  (cons
-				 (byte-optimize-body (cdr clause) for-effect))
+			   (byte-optimize-form (car clause) nil)
-			      (byte-compile-warn "malformed cond form: %s"
+			   (byte-optimize-body (cdr clause) for-effect))
-						 (prin1-to-string clause))
+			(byte-compile-warn "malformed cond form: %s"
-			      clause))
+					   (prin1-to-string clause))
-			 (cdr form))))
+			clause))
+		  (cdr form))))
 	  ((eq fn 'progn)
 	   ;; as an extra added bonus, this simplifies (progn <x>) --> <x>
 	   (if (cdr (cdr form))
 	       (progn
 		 (setq tmp (byte-optimize-body (cdr form) for-effect))
 "The source-level pass of the optimizer."
 ;;
 ;; First, optimize all sub-forms of this one.
 (setq form (byte-optimize-form-code-walker form for-effect))
 ;;
-;; after optimizing all subforms, optimize this form until it doesn't
+;; After optimizing all subforms, optimize this form until it doesn't
 ;; optimize any further.  This means that some forms will be passed through
 ;; the optimizer many times, but that's necessary to make the for-effect
 ;; processing do as much as possible.
 ;;
 (let (opt new)
 	  new)
 form)))
 (defun byte-optimize-body (forms all-for-effect)
-;; optimize the cdr of a progn or implicit progn; all forms is a list of
+;; Optimize the cdr of a progn or implicit progn; `forms' is a list of
 ;; forms, all but the last of which are optimized with the assumption that
-;; they are being called for effect.  the last is for-effect as well if
+;; they are being called for effect.  The last is for-effect as well if
-;; all-for-effect is true.  returns a new list of forms.
+;; all-for-effect is true.  Returns a new list of forms.
 (let ((rest forms)
 	(result nil)
 	fe new)
 (while rest
 (setq fe (or all-for-effect (cdr rest)))
 ;;; It is now safe to optimize code such that it introduces new bindings.
 ;; I'd like this to be a defsubst, but let's not be self-referential...
 (defmacro byte-compile-trueconstp (form)
 ;; Returns non-nil if FORM is a non-nil constant.
-(` (cond ((consp (, form)) (eq (car (, form)) 'quote))
+`(cond ((consp ,form) (eq (car ,form) 'quote))
-	   ((not (symbolp (, form))))
+	 ((not (symbolp ,form)))
-	   ((eq (, form) t)))))
+	 ((eq ,form t))
+	 ((keywordp ,form))))
 ;; If the function is being called with constant numeric args,
 ;; evaluate as much as possible at compile-time.  This optimizer
 ;; assumes that the function is associative, like + or *.
 (defun byte-optimize-associative-math (form)
 (put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate)
 ;; I'm not convinced that this is necessary.  Doesn't the optimizer loop
 ;; take care of this? - Jamie
-;; I think this may some times be necessary to reduce ie (quote 5) to 5,
+;; I think this may some times be necessary to reduce eg. (quote 5) to 5,
 ;; so arithmetic optimizers recognize the numeric constant.  - Hallvard
 (put 'quote 'byte-optimizer 'byte-optimize-quote)
 (defun byte-optimize-quote (form)
 (if (or (consp (nth 1 form))
 	  (and (symbolp (nth 1 form))
 (or (if (or (null last)
 		(eq (car-safe last) 'quote))
 	    (if (listp (nth 1 last))
 		(let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
 		  (nconc (list 'funcall fn) butlast
-			 (mapcar '(lambda (x) (list 'quote x)) (nth 1 last))))
+			 (mapcar #'(lambda (x) (list 'quote x)) (nth 1 last))))
 	      (byte-compile-warn
 	       "last arg to apply can't be a literal atom: %s"
 	       (prin1-to-string last))
 	      nil))
 	form)))
 	 elt exp expt fboundp featurep
 	 file-directory-p file-exists-p file-locked-p file-name-absolute-p
 	 file-newer-than-file-p file-readable-p file-symlink-p file-writable-p
 	 float floor format
 	 get get-buffer get-buffer-window getenv get-file-buffer
+	 ;; hash-table functions
+	 make-hash-table copy-hash-table
+	 gethash
+	 hash-table-count
+	 hash-table-rehash-size
+	 hash-table-rehash-threshold
+	 hash-table-size
+	 hash-table-test
+	 hash-table-type
+	 ;;
 	 int-to-string
 	 length log log10 logand logb logior lognot logxor lsh
 	 marker-buffer max member memq min mod
 	 next-window nth nthcdr number-to-string
 	 parse-colon-path previous-window
 	 string-to-int string-to-number substring symbol-plist
 	 tan upcase user-variable-p vconcat
 	 ;; XEmacs change: window-edges -> window-pixel-edges
 	 window-buffer window-dedicated-p window-pixel-edges window-height
 	 window-hscroll window-minibuffer-p window-width
-	 zerop))
+	 zerop
+	 ;; functions defined by cl
+	 oddp evenp plusp minusp
+	 abs expt signum last butlast ldiff
+	 pairlis gcd lcm
+	 isqrt floor* ceiling* truncate* round* mod* rem* subseq
+	 list-length get* getf
+	 ))
 (side-effect-and-error-free-fns
 '(arrayp atom
 	 bobp bolp buffer-end buffer-list buffer-size buffer-string bufferp
 	 car-safe case-table-p cdr-safe char-or-string-p char-table-p
 	 characterp commandp cons
 	 ;; XEmacs: extent functions, frame-live-p, various other stuff
 	 devicep device-live-p
 	 dot dot-marker eobp eolp eq eql equal eventp extentp
 	 extent-live-p floatp framep frame-live-p
 	 get-largest-window get-lru-window
+	 hash-table-p
 	 identity ignore integerp integer-or-marker-p interactive-p
 	 invocation-directory invocation-name
 	 ;; keymapp may autoload in XEmacs, so not on this list!
 	 list listp
 	 make-marker mark mark-marker markerp memory-limit minibuffer-window
 	 range-table-p
 	 selected-window sequencep stringp subrp symbolp syntax-table-p
 	 user-full-name user-login-name user-original-login-name
 	 user-real-login-name user-real-uid user-uid
 	 vector vectorp
-	 window-configuration-p window-live-p windowp)))
+	 window-configuration-p window-live-p windowp
-(while side-effect-free-fns
+	 ;; Functions defined by cl
-(put (car side-effect-free-fns) 'side-effect-free t)
+	 eql floatp-safe list* subst acons equalp random-state-p
-(setq side-effect-free-fns (cdr side-effect-free-fns)))
+	 copy-tree sublis
-(while side-effect-and-error-free-fns
+	 )))
-(put (car side-effect-and-error-free-fns) 'side-effect-free 'error-free)
+(dolist (fn side-effect-free-fns)
-(setq side-effect-and-error-free-fns (cdr side-effect-and-error-free-fns)))
+(put fn 'side-effect-free t))
-nil)
+(dolist (fn side-effect-and-error-free-fns)
+(put fn 'side-effect-free 'error-free)))
 (defun byte-compile-splice-in-already-compiled-code (form)
 ;; form is (byte-code "..." [...] n)
 (if (not (memq byte-optimize '(t lap)))
 (if (null (car (cdr (car lap))))
 	(setq lap (cdr lap)))
 (if endtag
 	(setq lap (cons (cons nil endtag) lap)))
 ;; remove addrs, lap = ( [ (op . arg) | (TAG tagno) ]* )
-(mapcar (function (lambda (elt)
+(mapcar #'(lambda (elt) (if (numberp elt) elt (cdr elt)))
-			(if (numberp elt)
-			    elt
-			  (cdr elt))))
 	    (nreverse lap))))
 ;;; peephole optimizer
 (eval-when-compile
 (or (compiled-function-p (symbol-function 'byte-optimize-form))
 (assq 'byte-code (symbol-function 'byte-optimize-form))
 (let ((byte-optimize nil)
 	   (byte-compile-warnings nil))
-(mapcar '(lambda (x)
+(mapcar
-		  (or noninteractive (message "compiling %s..." x))
+	#'(lambda (x)
-		  (byte-compile x)
+	    (or noninteractive (message "compiling %s..." x))
-		  (or noninteractive (message "compiling %s...done" x)))
+	    (byte-compile x)
-	       '(byte-optimize-form
+	    (or noninteractive (message "compiling %s...done" x)))
-		 byte-optimize-body
+	'(byte-optimize-form
-		 byte-optimize-predicate
+	  byte-optimize-body
-		 byte-optimize-binary-predicate
+	  byte-optimize-predicate
-		 ;; Inserted some more than necessary, to speed it up.
+	  byte-optimize-binary-predicate
-		 byte-optimize-form-code-walker
+	  ;; Inserted some more than necessary, to speed it up.
-		 byte-optimize-lapcode))))
+	  byte-optimize-form-code-walker
+	  byte-optimize-lapcode))))
 nil)
 ;;; byte-optimize.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/byte-optimize.el @ 380:8626e4521993 r21-2-5