Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv3882/src/compiler
Modified Files:
ir1-translators.lisp locall.lisp seqtran.lisp
Log Message:
1.0.7.28: compiler being nicer to the compiler
* In MAKE-XEP-LAMBDA-EXPRESSION, use EQL instead of = and NOT <
instead of >= to avoid additional rounds of deftransforms and
lambda-conversion.
* Add a source transform for %COERCE-CALLABLE-TO-FUN to pick of
simple cases, also avoid inserting additional lambdas to the code.
* Use %FUNCALL and %COERCE-CALLABLE-TO-FUN in MAPFOO-TRANSFORM,
providing not just faster compilation, but also making (MAPCAR F
...) faster by lifting the %C-C-T-F out of the loop.
This work was based on Juho's observation that a major source of
compiler slowness are all the lambdas generated by transforms: not
that this changes the big picture in any way -- just shaves a few
corners. If you wish to get a gut feeling of what is going on, stick
a (PRINT (LIST DEBUG-NAME BODY)) in IR1-CONVERT-INLINE-LAMBDA.
Index: ir1-translators.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1-translators.lisp,v
retrieving revision 1.81
retrieving revision 1.82
diff -u -d -r1.81 -r1.82
--- ir1-translators.lisp 12 Jul 2007 10:31:21 -0000 1.81
+++ ir1-translators.lisp 17 Jul 2007 22:26:30 -0000 1.82
@@ -575,7 +575,7 @@
;;; directly to %FUNCALL, instead of waiting around for type
;;; inference.
(define-source-transform funcall (function &rest args)
- (if (and (consp function) (eq (car function) 'function))
+ (if (and (consp function) (member (car function) '(function lambda)))
`(%funcall ,function ,@args)
(let ((name (constant-global-fun-name function)))
(if name
@@ -585,6 +585,11 @@
(deftransform %coerce-callable-to-fun ((thing) (function) *)
"optimize away possible call to FDEFINITION at runtime"
'thing)
+
+(define-source-transform %coerce-callable-to-fun (thing)
+ (if (and (consp thing) (member (car thing) '(function lambda)))
+ thing
+ (values nil t)))
;;;; LET and LET*
;;;;
Index: locall.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/locall.lisp,v
retrieving revision 1.78
retrieving revision 1.79
diff -u -d -r1.78 -r1.79
--- locall.lisp 19 Feb 2007 11:55:53 -0000 1.78
+++ locall.lisp 17 Jul 2007 22:26:30 -0000 1.79
@@ -191,7 +191,7 @@
(optional-dispatch-entry-point-fun fun 0)
(loop for ep in (optional-dispatch-entry-points fun)
and n from min
- do (entries `((= ,n-supplied ,n)
+ do (entries `((eql ,n-supplied ,n)
(%funcall ,(force ep) ,@(subseq temps 0 n)))))
`(lambda (,n-supplied ,@temps)
;; FIXME: Make sure that INDEX type distinguishes between
@@ -201,7 +201,9 @@
(cond
,@(if more (butlast (entries)) (entries))
,@(when more
- `((,(if (zerop min) t `(>= ,n-supplied ,max))
+ ;; KLUDGE: (NOT (< ...)) instead of >= avoids one round of
+ ;; deftransforms and lambda-conversion.
+ `((,(if (zerop min) t `(not (< ,n-supplied ,max)))
,(let ((n-context (gensym))
(n-count (gensym)))
`(multiple-value-bind (,n-context ,n-count)
Index: seqtran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/seqtran.lisp,v
retrieving revision 1.73
retrieving revision 1.74
diff -u -d -r1.73 -r1.74
--- seqtran.lisp 17 Jul 2007 18:36:33 -0000 1.73
+++ seqtran.lisp 17 Jul 2007 22:26:30 -0000 1.74
@@ -27,31 +27,30 @@
(args-to-fn (if take-car `(car ,v) v))))
(let* ((fn-sym (gensym)) ; for ONCE-ONLY-ish purposes
- (call `(funcall ,fn-sym . ,(args-to-fn)))
+ (call `(%funcall ,fn-sym . ,(args-to-fn)))
(endtest `(or ,@(tests))))
- (ecase accumulate
- (:nconc
- (let ((temp (gensym))
- (map-result (gensym)))
- `(let ((,fn-sym ,fn)
- (,map-result (list nil)))
- (do-anonymous ((,temp ,map-result) . ,(do-clauses))
- (,endtest (cdr ,map-result))
- (setq ,temp (last (nconc ,temp ,call)))))))
- (:list
- (let ((temp (gensym))
- (map-result (gensym)))
- `(let ((,fn-sym ,fn)
- (,map-result (list nil)))
- (do-anonymous ((,temp ,map-result) . ,(do-clauses))
- (,endtest (truly-the list (cdr ,map-result)))
- (rplacd ,temp (setq ,temp (list ,call)))))))
- ((nil)
- `(let ((,fn-sym ,fn)
- (,n-first ,(first arglists)))
- (do-anonymous ,(do-clauses)
- (,endtest (truly-the list ,n-first))
- ,call))))))))
+
+ `(let ((,fn-sym (%coerce-callable-to-fun ,fn)))
+ ,(ecase accumulate
+ (:nconc
+ (let ((temp (gensym))
+ (map-result (gensym)))
+ `(let ((,map-result (list nil)))
+ (do-anonymous ((,temp ,map-result) . ,(do-clauses))
+ (,endtest (cdr ,map-result))
+ (setq ,temp (last (nconc ,temp ,call)))))))
+ (:list
+ (let ((temp (gensym))
+ (map-result (gensym)))
+ `(let ((,map-result (list nil)))
+ (do-anonymous ((,temp ,map-result) . ,(do-clauses))
+ (,endtest (truly-the list (cdr ,map-result)))
+ (rplacd ,temp (setq ,temp (list ,call)))))))
+ ((nil)
+ `(let ((,n-first ,(first arglists)))
+ (do-anonymous ,(do-clauses)
+ (,endtest (truly-the list ,n-first))
+ ,call)))))))))
(define-source-transform mapc (function list &rest more-lists)
(mapfoo-transform function (cons list more-lists) nil t))
|