Changeset 11864

Timestamp:

05/15/09 07:36:38 (14 years ago)

Author:

ehuelsmann

Message:

Duplicate closure arrays if the compiland defines
bindings of itself: that allows storing a new binding
without clobbering other closure arrays.

File:

• branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (modified) (6 diffs)

branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -207 +207 @@
 (defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;")
 (defconstant +closure-binding-array+ "[Lorg/armedbear/lisp/ClosureBinding;")
+(defconstant +closure-binding+ "Lorg/armedbear/lisp/ClosureBinding;")
+(defconstant +closure-binding-class+ "org/armedbear/lisp/ClosureBinding")
 (defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol")
 (defconstant +lisp-symbol+ "Lorg/armedbear/lisp/Symbol;")
@@ -3010 +3012 @@
       (aload register)
       (emit 'aastore))))
+
+(defun duplicate-closure-array (compiland)
+  (let* ((*register* *register*)
+         (register (allocate-register)))
+    (aload (compiland-closure-register compiland))        ;; src
+    (emit-push-constant-int 0)                            ;; srcPos
+    (emit-push-constant-int (length *closure-variables*))
+    (emit 'anewarray "org/armedbear/lisp/ClosureBinding")     ;; dest
+    (emit 'dup)
+    (astore register)  ;; save dest value
+    (emit-push-constant-int 0)                            ;; destPos
+    (emit-push-constant-int (length *closure-variables*)) ;; length
+    (emit-invokestatic "java/lang/System" "arraycopy"
+                       (list "Ljava/lang/Object;" "I"
+                             "Ljava/lang/Object;" "I" "I") "V")
+    (aload register))) ;; reload dest value
+
+
 
 (defknown compile-local-function-call (t t t) t)
@@ -8045 +8065 @@
          (closure-args (intersection *closure-variables*
                                      (compiland-arg-vars compiland)))
+         (local-closure-vars
+          (find compiland *closure-variables* :key #'variable-compiland))
          (body (cddr p1-result))
          (*using-arg-array* nil)
@@ -8106 +8128 @@
                 (compiland-closure-register compiland)))
 
+    (when *closure-variables*
+      (cond
+        ((not *child-p*)
+         ;; if we're the ultimate parent: create the closure array
+         (emit-push-constant-int (length *closure-variables*))
+         (emit 'anewarray "org/armedbear/lisp/ClosureBinding"))
+        (local-closure-vars
+         (duplicate-closure-array compiland))))
+
     ;; Move args from their original registers to the closure variables array
     (when (or closure-args
@@ -8111 +8142 @@
       (dformat t "~S moving arguments to closure array~%"
                (compiland-name compiland))
-      (if *child-p*
-          (aload (compiland-closure-register compiland))
-          (progn
-            ;; if we're the ultimate parent: create the closure array
-            (emit-push-constant-int (length *closure-variables*))
-            (emit 'anewarray "org/armedbear/lisp/ClosureBinding")))
       (dotimes (i (length *closure-variables*))
         ;; Loop over all slots, setting their value
@@ -8149 +8174 @@
             (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding"
                                      (list +lisp-object+))
-            (emit 'aastore))))
-
+            (emit 'aastore)))))
+
+    (when (or local-closure-vars (and *closure-variables* (not *child-p*)))
       (aver (not (null (compiland-closure-register compiland))))
-      (cond (*child-p*
-             (emit 'pop))
-            (t
-             (astore (compiland-closure-register compiland))))
+      (astore (compiland-closure-register compiland))
       (dformat t "~S done moving arguments to closure array~%"
                (compiland-name compiland)))