Changeset 13487

Timestamp:

08/13/11 14:25:49 (12 years ago)

Author:

ehuelsmann

Message:

Store instances of local functions in their parent compiland.

File:

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

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

@@ -1339 +1339 @@
   (declare-function (cadr name) t))
 
+
+(defun local-function-class-and-field (local-function)
+  (let ((local-function-parent-compiland
+         (compiland-parent (local-function-compiland local-function))))
+    (values (abcl-class-file-class-name
+             (compiland-class-file local-function-parent-compiland))
+            (local-function-field local-function))))
 
 (defknown declare-local-function (local-function) string)
@@ -2208 +2215 @@
           (t
            (dformat t "compile-local-function-call default case~%")
-           (let* ((g (declare-local-function local-function)))
-             (emit-getstatic *this-class* g +lisp-object+)
-                                        ; Stack: template-function
-             (when *closure-variables*
-               (emit-checkcast +lisp-compiled-closure+)
-               (duplicate-closure-array 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 *closure-variables*
+             (emit-checkcast +lisp-compiled-closure+)
+             (duplicate-closure-array compiland)
+             (emit-invokestatic +lisp+ "makeCompiledClosure"
+                                (list +lisp-object+ +closure-binding-array+)
+                                +lisp-object+))))
     (process-args args '(nil))
     (emit-call-execute (length args))
@@ -4060 +4068 @@
                    bytes)))))))
 
-(defun emit-make-compiled-closure-for-labels
-    (local-function compiland declaration)
-  (emit-getstatic *this-class* declaration +lisp-object+)
-  (let ((parent (compiland-parent compiland)))
+(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~%"
@@ -4077 +4087 @@
 (defun p2-labels-process-compiland (local-function)
   (let* ((compiland (local-function-compiland local-function)))
-    (cond (*file-compilation*
-           (compile-and-write-to-stream compiland)
-           (let ((g (declare-local-function local-function)))
-             (emit-make-compiled-closure-for-labels
-              local-function compiland g)))
-          (t
-           (with-open-stream (stream (sys::%make-byte-array-output-stream))
-             (compile-and-write-to-stream compiland stream)
-             (let* ((bytes (sys::%get-output-stream-bytes stream))
-                    (g (declare-local-function local-function)))
-               (sys::put-memory-function *memory-class-loader*
-                                         (class-name-internal
-                                          (abcl-class-file-class-name
-                                           (compiland-class-file compiland)))
-                  bytes)
-               (emit-make-compiled-closure-for-labels
-                local-function compiland g)
-               ))))))
+    (cond
+      (*file-compilation*
+       (compile-and-write-to-stream compiland)
+       (emit-make-compiled-closure-for-labels local-function))
+      (t
+       (with-open-stream (stream (sys::%make-byte-array-output-stream))
+         (compile-and-write-to-stream compiland stream)
+         (let* ((bytes (sys::%get-output-stream-bytes stream)))
+           (sys::put-memory-function *memory-class-loader*
+                                     (class-name-internal
+                                      (abcl-class-file-class-name
+                                       (compiland-class-file compiland)))
+                                     bytes)
+           (emit-make-compiled-closure-for-labels local-function)))))))
 
 (defknown p2-flet-node (t t t) t)
@@ -4139 +4145 @@
     (cond (*file-compilation*
            (compile-and-write-to-stream compiland)
-           (emit-getstatic *this-class*
-                           (declare-local-function local-function)
-                           +lisp-object+))
+           (multiple-value-bind
+                 (class field)
+               (local-function-class-and-field local-function)
+             (emit-getstatic class field +lisp-object+)))
           (t
            (with-open-stream (stream (sys::%make-byte-array-output-stream))
@@ -4151 +4158 @@
                                            (compiland-class-file compiland)))
                                          bytes)
-               (emit-getstatic *this-class*
-                               (declare-local-function local-function)
-                               +lisp-object+)))))
+               (multiple-value-bind
+                     (class field)
+                   (local-function-class-and-field local-function)
+                 (emit-getstatic class field +lisp-object+))))))
     (cond ((null *closure-variables*))  ; Nothing to do.
           ((compiland-closure-register *current-compiland*)
@@ -4185 +4193 @@
                               'stack nil))
             (t
-             (let ((g (declare-local-function local-function)))
-               (emit-getstatic *this-class* g +lisp-object+)
-                                        ; Stack: template-function
-
-               (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)
@@ -4223 +4231 @@
                               'stack nil))
             (t
-             (let ((g (declare-local-function local-function)))
-               (emit-getstatic *this-class*
-                     g +lisp-object+))))) ; Stack: template-function
+             (multiple-value-bind
+                   (class field)
+                 (local-function-class-and-field)
+                ; Stack: template-function
+               (emit-getstatic class field +lisp-object+)))))
          ((and (member name *functions-defined-in-current-file* :test #'equal)
                (not (notinline-p name)))