Changeset 13488 for trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Timestamp:

08/13/11 20:26:01 (12 years ago)

Author:

ehuelsmann

Message:

Eliminate the need for functions defined using LABELS to be stored
in closures. Code elimination! Yay!

File:

• trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (modified) (14 diffs)

trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -1076 +1076 @@
 (defknown declare-field (t t t) t)
 (defun declare-field (name descriptor)
-  (let ((field (make-field name descriptor
-                           :flags '(:final :static :private))))
+  (let ((field (make-field name descriptor :flags '(:final :static))))
     (class-add-field *class-file* field)))
 
@@ -1349 +1348 @@
 (defknown declare-local-function (local-function) string)
 (defun declare-local-function (local-function)
-  (declare-with-hashtable
-   local-function *declared-functions* ht g
-   (setf g (symbol-name (gensym "LFUN")))
-   (let ((class-name (abcl-class-file-class-name
-                      (compiland-class-file
-                       (local-function-compiland local-function)))))
-     (with-code-to-method
-         (*class-file* (abcl-class-file-constructor *class-file*))
-       ;; fixme *declare-inline*
-       (declare-field g +lisp-object+)
-       (emit-new class-name)
-       (emit 'dup)
-       (emit-invokespecial-init class-name '())
-       (emit-putstatic *this-class* g +lisp-object+)
-       (setf (gethash local-function ht) g)))))
+  (let ((class-name (abcl-class-file-class-name
+                     (compiland-class-file
+                      (local-function-compiland local-function))))
+        (field-name (local-function-field local-function)))
+    (with-code-to-method
+        (*class-file* (abcl-class-file-constructor *class-file*))
+      ;; fixme *declare-inline*
+      (declare-field field-name +lisp-object+)
+      (emit-new class-name)
+      (emit 'dup)
+      (emit-invokespecial-init class-name '())
+      (emit-putstatic *this-class* field-name +lisp-object+))))
 
 
@@ -2196 +2192 @@
          (local-function (find-local-function op))
          (*register* *register*))
-    (cond ((local-function-variable local-function)
-           ;; LABELS
-           (dformat t "compile-local-function-call LABELS case variable = ~S~%"
-                   (variable-name (local-function-variable local-function)))
-           (compile-var-ref (make-var-ref
-                             (local-function-variable local-function))
-                            'stack nil))
+    (cond
           ((local-function-environment local-function)
            (assert (local-function-references-allowed-p local-function))
@@ -4041 +4031 @@
   "Creates a class file associated with `compiland`, writing it
 either to stream or the pathname of the class file if `stream' is NIL."
-  (let* ((class-file (compiland-class-file compiland))
-         (pathname (abcl-class-file-pathname class-file)))
+  (let* ((pathname (funcall *pathnames-generator*))
+         (class-file (make-abcl-class-file :pathname pathname)))
+    (setf (compiland-class-file compiland) class-file)
     (with-open-stream (f (or stream
                              (open pathname :direction :output
@@ -4068 +4059 @@
                    bytes)))))))
 
-(defun emit-make-compiled-closure-for-labels (local-function)
-  (let ((parent (compiland-parent (local-function-compiland local-function))))
-    (multiple-value-bind
-          (class field)
-        (local-function-class-and-field local-function)
-      (emit-getstatic class field +lisp-object+))
-    (when (compiland-closure-register parent)
-      (dformat t "(compiland-closure-register parent) = ~S~%"
-               (compiland-closure-register parent))
-      (emit-checkcast +lisp-compiled-closure+)
-      (duplicate-closure-array parent)
-      (emit-invokestatic +lisp+ "makeCompiledClosure"
-                         (list +lisp-object+ +closure-binding-array+)
-                         +lisp-object+)))
-  (emit-move-to-variable (local-function-variable local-function)))
-
 (defknown p2-labels-process-compiland (t) t)
 (defun p2-labels-process-compiland (local-function)
@@ -4089 +4064 @@
     (cond
       (*file-compilation*
-       (compile-and-write-to-stream compiland)
-       (emit-make-compiled-closure-for-labels local-function))
+       (compile-and-write-to-stream compiland))
       (t
        (with-open-stream (stream (sys::%make-byte-array-output-stream))
@@ -4099 +4073 @@
                                       (abcl-class-file-class-name
                                        (compiland-class-file compiland)))
-                                     bytes)
-           (emit-make-compiled-closure-for-labels local-function)))))))
+                                     bytes)))))))
 
 (defknown p2-flet-node (t t t) t)
@@ -4126 +4099 @@
          (body (cddr form)))
     (dolist (local-function local-functions)
-      (push local-function *local-functions*)
-      (push (local-function-variable local-function) *visible-variables*))
-    (dolist (local-function local-functions)
-      (let ((variable (local-function-variable local-function)))
-        (aver (null (variable-register variable)))
-        (unless (variable-closure-index variable)
-          (setf (variable-register variable) (allocate-register nil)))))
+      (push local-function *local-functions*))
     (dolist (local-function local-functions)
       (p2-labels-process-compiland local-function))
@@ -4142 +4109 @@
 (defun p2-lambda (local-function target)
   (let ((compiland (local-function-compiland local-function)))
-    (aver (not (null (compiland-class-file compiland))))
     (cond (*file-compilation*
            (compile-and-write-to-stream compiland)
@@ -4186 +4152 @@
          ((setf local-function (find-local-function name))
           (dformat t "p2-function 1~%")
-          (cond
-            ((local-function-variable local-function)
-             (dformat t "p2-function 2 emitting var-ref~%")
-             (compile-var-ref (make-var-ref
-                               (local-function-variable local-function))
-                              'stack nil))
-            (t
-             (multiple-value-bind
-                   (class field)
-                 (local-function-class-and-field local-function)
-               (emit-getstatic class field +lisp-object+))
-             (when (compiland-closure-register *current-compiland*)
-               (emit-checkcast +lisp-compiled-closure+)
-               (duplicate-closure-array *current-compiland*)
-               (emit-invokestatic +lisp+ "makeCompiledClosure"
-                                  (list +lisp-object+ +closure-binding-array+)
-                                  +lisp-object+))))
+          (multiple-value-bind
+                (class field)
+              (local-function-class-and-field local-function)
+            (emit-getstatic class field +lisp-object+))
+          (when (compiland-closure-register *current-compiland*)
+            (emit-checkcast +lisp-compiled-closure+)
+            (duplicate-closure-array *current-compiland*)
+            (emit-invokestatic +lisp+ "makeCompiledClosure"
+                               (list +lisp-object+ +closure-binding-array+)
+                               +lisp-object+))
           (emit-move-from-stack target))
          ((inline-ok name)
@@ -4224 +4183 @@
             (emit-move-from-stack target)
             (return-from p2-function))
-          (cond
-            ((local-function-variable local-function)
-             (dformat t "p2-function 2~%")
-             (compile-var-ref (make-var-ref
-                               (local-function-variable local-function))
-                              'stack nil))
-            (t
-             (multiple-value-bind
-                   (class field)
-                 (local-function-class-and-field)
-                ; Stack: template-function
-               (emit-getstatic class field +lisp-object+)))))
+          (multiple-value-bind
+                (class field)
+              (local-function-class-and-field local-function)
+                                        ; Stack: template-function
+            (emit-getstatic class field +lisp-object+)))
          ((and (member name *functions-defined-in-current-file* :test #'equal)
                (not (notinline-p name)))
@@ -7102 +7054 @@
 
 
-(defun assign-field-and-class-name (local-function)
-  (let* ((pathname (funcall *pathnames-generator*))
-         (class-file (make-abcl-class-file :pathname pathname))
-         (compiland (local-function-compiland local-function)))
-    (setf (compiland-class-file compiland) class-file))
+(defun assign-field-name (local-function)
   (setf (local-function-field local-function)
-        (declare-local-function local-function)))
+        (symbol-name (gensym "LFUN"))))
 
 (defknown p2-compiland (t) t)
@@ -7162 +7110 @@
 
       (dolist (local-function (compiland-children compiland))
-        (assign-field-and-class-name local-function))
+        (assign-field-name local-function))
 
       (dolist (var (compiland-arg-vars compiland))
@@ -7308 +7256 @@
       ;; Warn if any unused args. (Is this the right place?)
       (check-for-unused-variables (compiland-arg-vars compiland))
+
+      (dolist (local-function (compiland-children compiland))
+        (when (compiland-class-file (local-function-compiland local-function))
+          (declare-local-function local-function)))
 
       ;; Go back and fill in prologue.