[armedbear-cvs] r11480 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Fri Dec 26 10:14:11 2008
New Revision: 11480

Log:
Revert r11472: somehow macro-expansion was influenced by it (badly).

Note: This commit should come back, but in modified form.


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

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Fri Dec 26 10:14:11 2008
@@ -191,7 +191,6 @@
 (defconstant +lisp-return-class+ "org/armedbear/lisp/Return")
 (defconstant +lisp-go-class+ "org/armedbear/lisp/Go")
 (defconstant +lisp-ctf-class+ "org/armedbear/lisp/ClosureTemplateFunction")
-(defconstant +lisp-ctf+ "Lorg/armedbear/lisp/ClosureTemplateFunction;")
 (defconstant +lisp-compiled-closure-class+ "org/armedbear/lisp/CompiledClosure")
 (defconstant +lisp-compiled-function-class+ "org/armedbear/lisp/CompiledFunction")
 (defconstant +lisp-primitive-class+ "org/armedbear/lisp/Primitive")
@@ -2845,15 +2844,6 @@
       (emit 'aload register)
       (emit 'aastore))))
 
-
-(defun emit-dup-ctf-and-set-context (compiland)
-  (emit 'checkcast +lisp-ctf-class+)
-  (emit-invokevirtual +lisp-ctf-class+ "dup" nil +lisp-ctf+)
-  (emit 'aload (compiland-closure-register compiland))
-  (emit-invokevirtual +lisp-ctf-class+ "setContext"
-                      (list +lisp-object-array+)
-                      +lisp-ctf+))
-
 (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.
@@ -2884,7 +2874,11 @@
                          (declare-object (local-function-function local-function)))))
              (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function
              (when *closure-variables*
-               (emit-dup-ctf-and-set-context compiland)))))
+               (emit 'checkcast +lisp-ctf-class+)
+               (emit 'aload (compiland-closure-register compiland))
+               (emit-invokestatic +lisp-class+ "makeCompiledClosure"
+                                  (list +lisp-object+ +lisp-object-array+)
+                                  +lisp-object+)))))
     (let ((must-clear-values nil))
       (declare (type boolean must-clear-values))
       (cond ((> (length args) call-registers-limit)
@@ -4789,7 +4783,13 @@
 
                (let ((parent (compiland-parent compiland)))
                  (when (compiland-closure-register parent)
-                   (emit-dup-ctf-and-set-context parent)))
+                   (dformat t "(compiland-closure-register parent) = ~S~%"
+                            (compiland-closure-register parent))
+                   (emit 'checkcast +lisp-ctf-class+)
+                   (emit 'aload (compiland-closure-register parent))
+                   (emit-invokestatic +lisp-class+ "makeCompiledClosure"
+                                      (list +lisp-object+ +lisp-object-array+)
+                                      +lisp-object+)))
 
                (dformat t "p2-flet-process-compiland var-set ~S~%" (variable-name (local-function-variable local-function)))
                (emit 'var-set (local-function-variable local-function)))))
@@ -4809,7 +4809,13 @@
 
                        (let ((parent (compiland-parent compiland)))
                          (when (compiland-closure-register parent)
-                           (emit-dup-ctf-and-set-context parent)))
+                           (dformat t "(compiland-closure-register parent) = ~S~%"
+                                    (compiland-closure-register parent))
+                           (emit 'checkcast +lisp-ctf-class+)
+                           (emit 'aload (compiland-closure-register parent))
+                           (emit-invokestatic +lisp-class+ "makeCompiledClosure"
+                                              (list +lisp-object+ +lisp-object-array+)
+                                              +lisp-object+)))
 
                        (emit 'var-set (local-function-variable local-function)))))
                (delete-file pathname)))))))
@@ -4833,7 +4839,13 @@
 
                (let ((parent (compiland-parent compiland)))
                  (when (compiland-closure-register parent)
-                   (emit-dup-ctf-and-set-context parent)))
+                   (dformat t "(compiland-closure-register parent) = ~S~%"
+                            (compiland-closure-register parent))
+                   (emit 'checkcast +lisp-ctf-class+)
+                   (emit 'aload (compiland-closure-register parent))
+                   (emit-invokestatic +lisp-class+ "makeCompiledClosure"
+                                      (list +lisp-object+ +lisp-object-array+)
+                                      +lisp-object+)))
 
 
                (emit 'var-set (local-function-variable local-function)))))
@@ -4850,7 +4862,13 @@
 
                      (let ((parent (compiland-parent compiland)))
                        (when (compiland-closure-register parent)
-                         (emit-dup-ctf-and-set-context parent)))
+                         (dformat t "(compiland-closure-register parent) = ~S~%"
+                                  (compiland-closure-register parent))
+                         (emit 'checkcast +lisp-ctf-class+)
+                         (emit 'aload (compiland-closure-register parent))
+                         (emit-invokestatic +lisp-class+ "makeCompiledClosure"
+                                            (list +lisp-object+ +lisp-object-array+)
+                                            +lisp-object+)))
 
                      (emit 'var-set (local-function-variable local-function))))
                (delete-file pathname)))))))
@@ -4928,9 +4946,11 @@
                (delete-file pathname)))))
     (cond ((null *closure-variables*)) ; Nothing to do.
           ((compiland-closure-register *current-compiland*)
-           (emit-dup-ctf-and-set-context *current-compiland*)
-           ; Stack: cloned template function
-           )
+           (emit 'aload (compiland-closure-register *current-compiland*))
+           (emit-invokestatic +lisp-class+ "makeCompiledClosure"
+                              (list +lisp-object+ +lisp-object-array+)
+                              +lisp-object+)
+           (emit 'checkcast +lisp-compiled-closure-class+)) ; Stack: compiled-closure
           (t
            (aver nil))) ;; Shouldn't happen.
     (emit-move-from-stack target)))
@@ -4957,7 +4977,11 @@
                            (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function
 
                            (when (compiland-closure-register *current-compiland*)
-                             (emit-dup-ctf-and-set-context *current-compiland*)))))
+                             (emit 'checkcast +lisp-ctf-class+)
+                             (emit 'aload (compiland-closure-register *current-compiland*))
+                             (emit-invokestatic +lisp-class+ "makeCompiledClosure"
+                                                (list +lisp-object+ +lisp-object-array+)
+                                                +lisp-object+)))))
                   (emit-move-from-stack target))
                  ((inline-ok name)
                   (emit 'getstatic *this-class*