[armedbear-cvs] r11798 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Wed Apr 29 15:49:19 2009
New Revision: 11798

Log:
Remove the use of XEPs (eXternal Entry Points) which
were optimizing for the 1-optional-argument special case
by calling an internal entry point if that argument was
provided and the XEP otherwise. This is too much code
to justify this case.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	Wed Apr 29 15:49:19 2009
@@ -909,13 +909,6 @@
 
 (initialize-p1-handlers)
 
-(defun invoke-compile-xep (xep-lambda-expression compiland)
-  (let ((xep-compiland
-	 (make-compiland :lambda-expression 
-			 (precompile-form xep-lambda-expression t)
-			 :class-file (compiland-class-file compiland))))
-    (compile-xep xep-compiland)))
-
 (defun p1-compiland (compiland)
 ;;   (format t "p1-compiland name = ~S~%" (compiland-name compiland))
   (let ((form (compiland-lambda-expression compiland)))
@@ -926,54 +919,6 @@
     (let* ((lambda-list (cadr form))
            (body (cddr form)))
 
-      (when (and (null (compiland-parent compiland))
-                 ;; FIXME support SETF functions!
-                 (symbolp (compiland-name compiland)))
-        (when (memq '&OPTIONAL lambda-list)
-          (unless (or (memq '&KEY lambda-list) (memq '&REST lambda-list))
-            (let ((required-args (subseq lambda-list 0 (position '&OPTIONAL lambda-list)))
-                  (optional-args (cdr (memq '&OPTIONAL lambda-list))))
-            (dformat t "optional-args = ~S~%" optional-args)
-            (when (= (length optional-args) 1)
-              (let* ((optional-arg (car optional-args))
-                     (name (if (consp optional-arg) (%car optional-arg) optional-arg))
-                     (initform (if (consp optional-arg) (cadr optional-arg) nil))
-                     (supplied-p-var (and (consp optional-arg)
-                                          (= (length optional-arg) 3)
-                                          (third optional-arg)))
-                     (all-args
-                      (append required-args (list name)
-                              (when supplied-p-var (list supplied-p-var)))))
-                (when (<= (length all-args) call-registers-limit)
-                  (dformat t "optional-arg = ~S~%" optional-arg)
-                  (dformat t "supplied-p-var = ~S~%" supplied-p-var)
-                  (dformat t "required-args = ~S~%" required-args)
-                  (dformat t "all-args = ~S~%" all-args)
-                  (cond (supplied-p-var
-                         (let ((xep-lambda-expression
-                                `(lambda ,required-args
-                                   (let* ((,name ,initform)
-                                          (,supplied-p-var nil))
-                                     (%call-internal , at all-args)))))
-                           (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression)
-			   (invoke-compile-xep xep-lambda-expression compiland))
-                         (let ((xep-lambda-expression
-                                `(lambda ,(append required-args (list name))
-                                   (let* ((,supplied-p-var t))
-                                     (%call-internal , at all-args)))))
-                           (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression)
-			   (invoke-compile-xep xep-lambda-expression compiland))
-                         (setf lambda-list all-args)
-                         (setf (compiland-kind compiland) :internal))
-                        (t
-                         (let ((xep-lambda-expression
-                                `(lambda ,required-args
-                                   (let* ((,name ,initform))
-                                     (,(compiland-name compiland) , at all-args)))))
-                           (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression)
-			   (invoke-compile-xep xep-lambda-expression compiland))
-                         (setf lambda-list all-args))))))))))
-
       (let* ((closure (make-closure `(lambda ,lambda-list nil) nil))
              (syms (sys::varlist closure))
              (vars nil))

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Wed Apr 29 15:49:19 2009
@@ -8095,55 +8095,6 @@
              ;; attributes count
              (write-u2 0 stream))))))
 
-(defun compile-xep (xep)
-  (declare (type compiland xep))
-  (let ((*all-variables* ())
-        (*closure-variables* ())
-        (*current-compiland* xep)
-        (*speed* 3)
-        (*safety* 0)
-        (*debug* 0))
-
-    (aver (not (null (compiland-class-file xep))))
-
-    ;; Pass 1.
-    (p1-compiland xep)
-;;     (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*))
-    (setf *closure-variables*
-          (remove-if-not #'variable-used-non-locally-p *all-variables*))
-    (setf *closure-variables*
-          (remove-if #'variable-special-p *closure-variables*))
-;;     (dformat t "*closure-variables* = ~S~%" (mapcar #'variable-name *closure-variables*))
-
-    (when *closure-variables*
-      (let ((i 0))
-        (dolist (var (reverse *closure-variables*))
-          (setf (variable-closure-index var) i)
-          (dformat t "var = ~S closure index = ~S~%" (variable-name var)
-                   (variable-closure-index var))
-          (incf i))))
-
-    ;; Pass 2.
-    (with-class-file (compiland-class-file xep)
-      (p2-compiland xep))))
-
-
-(defun p2-%call-internal (form target representation)
-  (dformat t "p2-%call-internal~%")
-  (aload 0) ; this
-  (let ((args (cdr form))
-        (must-clear-values nil))
-    (dformat t "args = ~S~%" args)
-    (dolist (arg args)
-      (compile-form arg 'stack nil)
-      (unless must-clear-values
-        (unless (single-valued-p arg)
-          (setf must-clear-values t))))
-    (let ((arg-types (lisp-object-arg-types (length args)))
-          (return-type +lisp-object+))
-      (emit-invokevirtual *this-class* "_execute" arg-types return-type))
-    (emit-move-from-stack target representation)))
-
 (defknown p2-compiland-process-type-declarations (list) t)
 (defun p2-compiland-process-type-declarations (body)
   (flet ((process-declaration (name type)
@@ -8764,7 +8715,6 @@
                                multiple-value-prog1
                                nth
                                progn))
-  (install-p2-handler '%call-internal      'p2-%call-internal)
   (install-p2-handler '%ldb                'p2-%ldb)
   (install-p2-handler '%make-structure     'p2-%make-structure)
   (install-p2-handler '*                   'p2-times)