[armedbear-cvs] r11864 - branches/closure-fixes/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Fri May 15 07:36:41 UTC 2009
Author: ehuelsmann
Date: Fri May 15 03:36:38 2009
New Revision: 11864
Log:
Duplicate closure arrays if the compiland defines
bindings of itself: that allows storing a new binding
without clobbering other closure arrays.
Modified:
branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Fri May 15 03:36:38 2009
@@ -206,6 +206,8 @@
(defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;")
(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;")
(defconstant +lisp-structure-object-class+ "org/armedbear/lisp/StructureObject")
@@ -3010,6 +3012,24 @@
(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)
(defun compile-local-function-call (form target representation)
"Compiles a call to a function marked as `*child-p*'; a local function.
@@ -8044,6 +8064,8 @@
(args (cadr p1-result))
(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)
(*hairy-arglist-p* nil)
@@ -8105,17 +8127,20 @@
(dformat t "p2-compiland 2 closure register = ~S~%"
(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
(and *closure-variables* (not *child-p*)))
(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
;; unconditionally if we're the parent creating it (using null
@@ -8148,13 +8173,11 @@
(assert (not "Can't happen!!"))))
(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)))
More information about the armedbear-cvs
mailing list