Changeset 13484

Timestamp:

08/13/11 08:29:08 (10 years ago)

Author:

ehuelsmann

Message:

Store local functions in the parent compiland, since you can't
reach the function from the compiland, but the other way around works.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• compiler-pass1.lisp (modified) (3 diffs)
• compiler-pass2.lisp (modified) (2 diffs)
• jvm.lisp (modified) (1 diff)

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

@@ -885 +885 @@
          (compiland (make-compiland :name name :parent *current-compiland*))
          (local-function (make-local-function :name name :compiland compiland)))
-    (push compiland (compiland-children *current-compiland*))
+    (push local-function (compiland-children *current-compiland*))
     (when variable-name
       (setf (local-function-variable local-function)
@@ -1004 +1004 @@
                                                        name (gensym "ANONYMOUS-LAMBDA-"))
                                              :lambda-expression lambda-form
-                                             :parent *current-compiland*)))
-             (push compiland (compiland-children *current-compiland*))
+                                             :parent *current-compiland*))
+                  (local-function (make-local-function :compiland compiland)))
+             (push local-function (compiland-children *current-compiland*))
              (multiple-value-bind (body decls)
                  (parse-body body)
@@ -1015 +1016 @@
                      (*current-compiland* compiland))
                  (p1-compiland compiland)))
-             (list 'FUNCTION compiland)))
+             (list 'FUNCTION local-function)))
           ((setf local-function (find-local-function (cadr form)))
            (dformat "p1-function local function ~S~%" (cadr form))

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

@@ -4141 +4141 @@
       (compile-progn-body body target representation))))
 
-(defun p2-lambda (compiland target)
-  (aver (null (compiland-class-file compiland)))
-  (cond (*file-compilation*
-         (compile-and-write-to-stream compiland)
-         (emit-getstatic *this-class*
-                         (declare-local-function
-                          (make-local-function :compiland compiland))
-                         +lisp-object+))
-        (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-getstatic *this-class*
-                         (declare-local-function
-                          (make-local-function
-                           :compiland compiland))
-                         +lisp-object+)))))
-  (cond ((null *closure-variables*))    ; Nothing to do.
-        ((compiland-closure-register *current-compiland*)
-         (duplicate-closure-array *current-compiland*)
-         (emit-invokestatic +lisp+ "makeCompiledClosure"
-                            (list +lisp-object+ +closure-binding-array+)
-                            +lisp-object+))
+(defun p2-lambda (local-function target)
+  (let ((compiland (local-function-compiland local-function)))
+    (aver (null (compiland-class-file compiland)))
+    (cond (*file-compilation*
+           (compile-and-write-to-stream compiland)
+           (emit-getstatic *this-class*
+                           (declare-local-function local-function)
+                           +lisp-object+))
+          (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-getstatic *this-class*
+                               (declare-local-function local-function)
+                               +lisp-object+)))))
+    (cond ((null *closure-variables*))  ; Nothing to do.
+          ((compiland-closure-register *current-compiland*)
+           (duplicate-closure-array *current-compiland*)
+           (emit-invokestatic +lisp+ "makeCompiledClosure"
+                              (list +lisp-object+ +closure-binding-array+)
+                              +lisp-object+))
                                         ; Stack: compiled-closure
-        (t
-         (aver nil))) ;; Shouldn't happen.
+          (t
+           (aver nil)))) ;; Shouldn't happen.
 
   (emit-move-from-stack target))
@@ -4251 +4249 @@
                               nil +lisp-object+)
           (emit-move-from-stack target))))
-      ((compiland-p name)
+      ((local-function-p name)
        (dformat t "p2-function case 3~%")
        (p2-lambda name target))

trunk/abcl/src/org/armedbear/lisp/jvm.lisp

@@ -200 +200 @@
   p1-result         ; the parse tree as created in pass 1
   parent            ; the parent for compilands which defined within another
-  children          ; List of local compilands
+  children          ; List of local functions
                     ; defined with FLET, LABELS or LAMBDA
   blocks            ; TAGBODY, PROGV, BLOCK, etc. blocks