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

Timestamp:

05/15/09 09:20:17 (15 years ago)

Author:

ehuelsmann

Message:

Create new closure arrays when creating new closures.
This prevents the parent from clobbering closures
which it already created, when changing its own closure
array.

Variable saving and restoring is no longer necessary:
all the closure array copying does the same thing (better).

File:

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

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

@@ -2992 +2992 @@
   (emit-move-from-stack target))
 
-(defun save-variables (variables)
-  (let ((saved-vars '()))
-    (dolist (variable variables)
-      (when (variable-closure-index variable)
-        (let ((register (allocate-register)))
-          (aload (compiland-closure-register *current-compiland*))
-          (emit-push-constant-int (variable-closure-index variable))
-          (emit 'aaload)
-          (astore register)
-          (push (cons variable register) saved-vars))))
-    saved-vars))
-
-(defun restore-variables (saved-vars)
-  (dolist (saved-var saved-vars)
-    (let ((variable (car saved-var))
-          (register (cdr saved-var)))
-      (aload (compiland-closure-register *current-compiland*))
-      (emit-push-constant-int (variable-closure-index variable))
-      (aload register)
-      (emit 'aastore))))
 
 (defun duplicate-closure-array (compiland)
@@ -3026 +3006 @@
     (emit-invokestatic "java/lang/System" "arraycopy"
                        (list "Ljava/lang/Object;" "I"
-                             "Ljava/lang/Object;" "I" "I") "V")
+                             "Ljava/lang/Object;" "I" "I") nil)
     (aload register))) ;; reload dest value
 
@@ -3041 +3021 @@
          (args (cdr form))
          (local-function (find-local-function op))
-         (*register* *register*)
-         (saved-vars '())
-         (label-START (gensym))
-         (label-END (gensym))
-         (label-EXIT (gensym)))
+         (*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)))
-           (unless (null (compiland-parent compiland))
-             (setf saved-vars
-                   (save-variables (intersection
-                                    (compiland-arg-vars (local-function-compiland local-function))
-                                    *visible-variables*))))
-;;            (emit 'var-ref (local-function-variable local-function) 'stack)
-           (when saved-vars
-             (label label-START))
            (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil))
           (t
@@ -3067 +3035 @@
              (when *closure-variables*
                (emit 'checkcast +lisp-ctf-class+)
-               (aload (compiland-closure-register compiland))
+               (duplicate-closure-array compiland)
                (emit-invokestatic +lisp-class+ "makeCompiledClosure"
                                   (list +lisp-object+ +closure-binding-array+)
@@ -3074 +3042 @@
     (emit-call-execute (length args))
     (fix-boxing representation nil)
-    (emit-move-from-stack target representation)
-    (when saved-vars
-      (emit 'goto label-EXIT)
-      (label label-END)
-      (restore-variables saved-vars)
-      (emit 'athrow)
-      (label label-EXIT)
-      (restore-variables saved-vars)
-      (push (make-handler :from label-START
-                          :to label-END
-                          :code label-END
-                          :catch-type 0) *handlers*)))
+    (emit-move-from-stack target representation))
   t)
 
@@ -4899 +4856 @@
          (compiland-closure-register parent))
       (emit 'checkcast +lisp-ctf-class+)
-      (aload (compiland-closure-register parent))
+      (duplicate-closure-array parent)
       (emit-invokestatic +lisp-class+ "makeCompiledClosure"
        (list +lisp-object+ +closure-binding-array+)
@@ -5047 +5004 @@
     (cond ((null *closure-variables*)) ; Nothing to do.
           ((compiland-closure-register *current-compiland*)
-           (aload (compiland-closure-register *current-compiland*))
+           (duplicate-closure-array *current-compiland*)
            (emit-invokestatic +lisp-class+ "makeCompiledClosure"
                               (list +lisp-object+ +closure-binding-array+)
@@ -5079 +5036 @@
                            (when (compiland-closure-register *current-compiland*)
                              (emit 'checkcast +lisp-ctf-class+)
-                             (aload (compiland-closure-register *current-compiland*))
+                             (duplicate-closure-array *current-compiland*)
                              (emit-invokestatic +lisp-class+ "makeCompiledClosure"
                                                 (list +lisp-object+ +closure-binding-array+)