[armedbear-cvs] r11861 - branches/closure-fixes/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Thu May 14 18:17:10 UTC 2009
Author: ehuelsmann
Date: Thu May 14 14:17:08 2009
New Revision: 11861
Log:
Work in progress on changing the closure array over from variables to bindings.
Added:
branches/closure-fixes/abcl/src/org/armedbear/lisp/ClosureBinding.java (contents, props changed)
Modified:
branches/closure-fixes/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java
branches/closure-fixes/abcl/src/org/armedbear/lisp/CompiledClosure.java
branches/closure-fixes/abcl/src/org/armedbear/lisp/Lisp.java
branches/closure-fixes/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
Added: branches/closure-fixes/abcl/src/org/armedbear/lisp/ClosureBinding.java
==============================================================================
--- (empty file)
+++ branches/closure-fixes/abcl/src/org/armedbear/lisp/ClosureBinding.java Thu May 14 14:17:08 2009
@@ -0,0 +1,50 @@
+/*
+ * ClosureBinding.java
+ *
+ * Copyright (C) 2009 Erik Huelsmann
+ * $Id$
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+ *
+ * As a special exception, the copyright holders of this library give you
+ * permission to link this library with independent modules to produce an
+ * executable, regardless of the license terms of these independent
+ * modules, and to copy and distribute the resulting executable under
+ * terms of your choice, provided that you also meet, for each linked
+ * independent module, the terms and conditions of the license of that
+ * module. An independent module is a module which is not derived from
+ * or based on this library. If you modify this library, you may extend
+ * this exception to your version of the library, but you are not
+ * obligated to do so. If you do not wish to do so, delete this
+ * exception statement from your version.
+ */
+
+package org.armedbear.lisp;
+
+/** This class serves merely to store a reference to an
+ * object, used in the closure array.
+ *
+ * Objects of this type are used to model the fact that
+ * closures close over bindings and not over values.
+ *
+ */
+public class ClosureBinding
+{
+ public LispObject value;
+
+ public ClosureBinding(LispObject value) {
+ this.value = value;
+ }
+}
\ No newline at end of file
Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java
==============================================================================
--- branches/closure-fixes/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java (original)
+++ branches/closure-fixes/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java Thu May 14 14:17:08 2009
@@ -37,7 +37,7 @@
implements Cloneable
{
- public LispObject[] ctx;
+ public ClosureBinding[] ctx;
public ClosureTemplateFunction(LispObject lambdaList)
throws ConditionThrowable
@@ -45,7 +45,7 @@
super(list(Symbol.LAMBDA, lambdaList), null);
}
- final public ClosureTemplateFunction setContext(LispObject[] context)
+ final public ClosureTemplateFunction setContext(ClosureBinding[] context)
{
ctx = context;
return this;
@@ -156,14 +156,14 @@
// "evaluate this template with these values"
// Zero args.
- public LispObject _execute(LispObject[] context) throws ConditionThrowable
+ public LispObject _execute(ClosureBinding[] context) throws ConditionThrowable
{
LispObject[] args = new LispObject[0];
return _execute(context, args);
}
// One arg.
- public LispObject _execute(LispObject[] context, LispObject first)
+ public LispObject _execute(ClosureBinding[] context, LispObject first)
throws ConditionThrowable
{
LispObject[] args = new LispObject[1];
@@ -172,7 +172,7 @@
}
// Two args.
- public LispObject _execute(LispObject[] context, LispObject first,
+ public LispObject _execute(ClosureBinding[] context, LispObject first,
LispObject second)
throws ConditionThrowable
{
@@ -183,7 +183,7 @@
}
// Three args.
- public LispObject _execute(LispObject[] context, LispObject first,
+ public LispObject _execute(ClosureBinding[] context, LispObject first,
LispObject second, LispObject third)
throws ConditionThrowable
{
@@ -195,7 +195,7 @@
}
// Four args.
- public LispObject _execute(LispObject[] context, LispObject first,
+ public LispObject _execute(ClosureBinding[] context, LispObject first,
LispObject second, LispObject third,
LispObject fourth)
throws ConditionThrowable
@@ -209,7 +209,7 @@
}
// Five args.
- public LispObject _execute(LispObject[] context, LispObject first,
+ public LispObject _execute(ClosureBinding[] context, LispObject first,
LispObject second, LispObject third,
LispObject fourth, LispObject fifth)
throws ConditionThrowable
@@ -224,7 +224,7 @@
}
// Six args.
- public LispObject _execute(LispObject[] context, LispObject first,
+ public LispObject _execute(ClosureBinding[] context, LispObject first,
LispObject second, LispObject third,
LispObject fourth, LispObject fifth,
LispObject sixth)
@@ -241,7 +241,7 @@
}
// Seven args.
- public LispObject _execute(LispObject[] context, LispObject first,
+ public LispObject _execute(ClosureBinding[] context, LispObject first,
LispObject second, LispObject third,
LispObject fourth, LispObject fifth,
LispObject sixth, LispObject seventh)
@@ -259,7 +259,7 @@
}
// Eight args.
- public LispObject _execute(LispObject[] context, LispObject first,
+ public LispObject _execute(ClosureBinding[] context, LispObject first,
LispObject second, LispObject third,
LispObject fourth, LispObject fifth,
LispObject sixth, LispObject seventh,
@@ -279,7 +279,7 @@
}
// Arg array.
- public LispObject _execute(LispObject[] context, LispObject[] args)
+ public LispObject _execute(ClosureBinding[] context, LispObject[] args)
throws ConditionThrowable
{
return notImplemented();
Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/CompiledClosure.java
==============================================================================
--- branches/closure-fixes/abcl/src/org/armedbear/lisp/CompiledClosure.java (original)
+++ branches/closure-fixes/abcl/src/org/armedbear/lisp/CompiledClosure.java Thu May 14 14:17:08 2009
@@ -36,9 +36,9 @@
public class CompiledClosure extends Function
{
private final ClosureTemplateFunction ctf;
- private final LispObject[] context;
+ private final ClosureBinding[] context;
- public CompiledClosure(ClosureTemplateFunction ctf, LispObject[] context)
+ public CompiledClosure(ClosureTemplateFunction ctf, ClosureBinding[] context)
{
super(ctf.getLambdaName(), ctf.getLambdaList());
this.ctf = ctf;
Modified: branches/closure-fixes/abcl/src/org/armedbear/lisp/Lisp.java
==============================================================================
--- branches/closure-fixes/abcl/src/org/armedbear/lisp/Lisp.java (original)
+++ branches/closure-fixes/abcl/src/org/armedbear/lisp/Lisp.java Thu May 14 14:17:08 2009
@@ -1186,7 +1186,7 @@
}
public static final LispObject makeCompiledClosure(LispObject template,
- LispObject[] context)
+ ClosureBinding[] context)
throws ConditionThrowable
{
ClosureTemplateFunction ctf = ((ClosureTemplateFunction) template).dup();
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 Thu May 14 14:17:08 2009
@@ -205,6 +205,7 @@
(defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject")
(defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;")
(defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;")
+(defconstant +closure-binding-array+ "[Lorg/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")
@@ -3047,7 +3048,7 @@
(emit 'checkcast +lisp-ctf-class+)
(aload (compiland-closure-register compiland))
(emit-invokestatic +lisp-class+ "makeCompiledClosure"
- (list +lisp-object+ +lisp-object-array+)
+ (list +lisp-object+ +closure-binding-array+)
+lisp-object+)))))
(process-args args)
(emit-call-execute (length args))
@@ -3919,6 +3920,10 @@
(emit-invokevirtual +lisp-thread-class+ "bindSpecial"
(list +lisp-symbol+ +lisp-object+) nil))
((variable-closure-index variable)
+ (emit 'new "org/armedbear/lisp/ClosureBinding")
+ (emit 'dup)
+ (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding"
+ (list +lisp-object+))
(aload (compiland-closure-register *current-compiland*))
(emit 'swap) ; array value
(emit-push-constant-int (variable-closure-index variable))
@@ -4195,16 +4200,17 @@
(emit-array-store (variable-representation variable)))
((variable-closure-index variable)
(aload (compiland-closure-register *current-compiland*))
- (emit-swap representation nil)
(emit-push-constant-int (variable-closure-index variable))
- (emit-swap representation :int)
- (emit-array-store (variable-representation variable)))
+ (emit 'aaload)
+ (emit-swap representation nil)
+ (emit 'putfield "org/armedbear/lisp/ClosureBinding" "value"
+ "Lorg/armedbear/lisp/LispObject;"))
(t
;;###FIXME: We might want to address the "temp-register" case too.
(assert nil))))))
(defun emit-push-variable (variable)
- (flet ((emit-array-store (representation)
+ (flet ((emit-array-load (representation)
(emit (ecase representation
((:int :boolean :char)
'iaload)
@@ -4224,11 +4230,13 @@
((variable-index variable)
(aload (compiland-argument-register *current-compiland*))
(emit-push-constant-int (variable-index variable))
- (emit-array-store (variable-representation variable)))
+ (emit-array-load (variable-representation variable)))
((variable-closure-index variable)
(aload (compiland-closure-register *current-compiland*))
(emit-push-constant-int (variable-closure-index variable))
- (emit-array-store (variable-representation variable)))
+ (emit 'aaload)
+ (emit 'getfield "org/armedbear/lisp/ClosureBinding" "value"
+ "Lorg/armedbear/lisp/LispObject;"))
(t ;;###FIXME: We might want to address the "temp-register" case too.
(assert nil)))))
@@ -4869,7 +4877,7 @@
(emit 'checkcast +lisp-ctf-class+)
(aload (compiland-closure-register parent))
(emit-invokestatic +lisp-class+ "makeCompiledClosure"
- (list +lisp-object+ +lisp-object-array+)
+ (list +lisp-object+ +closure-binding-array+)
+lisp-object+)))
(emit-move-to-variable (local-function-variable local-function)))
@@ -5017,7 +5025,7 @@
((compiland-closure-register *current-compiland*)
(aload (compiland-closure-register *current-compiland*))
(emit-invokestatic +lisp-class+ "makeCompiledClosure"
- (list +lisp-object+ +lisp-object-array+)
+ (list +lisp-object+ +closure-binding-array+)
+lisp-object+)
(emit 'checkcast +lisp-compiled-closure-class+)) ; Stack: compiled-closure
(t
@@ -5049,7 +5057,7 @@
(emit 'checkcast +lisp-ctf-class+)
(aload (compiland-closure-register *current-compiland*))
(emit-invokestatic +lisp-class+ "makeCompiledClosure"
- (list +lisp-object+ +lisp-object-array+)
+ (list +lisp-object+ +closure-binding-array+)
+lisp-object+)))))
(emit-move-from-stack target))
((inline-ok name)
@@ -7886,19 +7894,20 @@
(setf *hairy-arglist-p* t)
(return-from analyze-args
(if *closure-variables*
- (get-descriptor (list +lisp-object-array+ +lisp-object-array+)
- +lisp-object+)
+ (get-descriptor (list +closure-binding-array+
+ +lisp-object-array+)
+ +lisp-object+)
(get-descriptor (list +lisp-object-array+)
- +lisp-object+))))
+ +lisp-object+))))
(cond (*closure-variables*
(return-from analyze-args
(cond ((<= arg-count call-registers-limit)
- (get-descriptor (list* +lisp-object-array+
+ (get-descriptor (list* +closure-binding-array+
(lisp-object-arg-types arg-count))
+lisp-object+))
(t (setf *using-arg-array* t)
(setf (compiland-arity compiland) arg-count)
- (get-descriptor (list +lisp-object-array+ +lisp-object-array+) ;; FIXME
+ (get-descriptor (list +closure-binding-array+ +lisp-object-array+) ;; FIXME
+lisp-object+)))))
(t
(return-from analyze-args
@@ -8105,7 +8114,7 @@
(emit-push-constant-int (length *closure-variables*))
(dformat t "p2-compiland ~S anewarray 1~%"
(compiland-name compiland))
- (emit 'anewarray "org/armedbear/lisp/LispObject")))
+ (emit 'anewarray "org/armedbear/lisp/ClosureBinding")))
(dolist (variable closure-args)
(dformat t "moving variable ~S~%" (variable-name variable))
(cond ((variable-register variable)
@@ -8114,6 +8123,10 @@
(emit 'dup) ; array
(emit-push-constant-int (variable-closure-index variable))
(aload (variable-register variable))
+ (emit 'new "org/armedbear/lisp/ClosureBinding")
+ (emit 'dup)
+ (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding"
+ (list "Lorg/armedbear/lisp/LisObject;"))
(emit 'aastore)
(setf (variable-register variable) nil))
((variable-index variable)
@@ -8122,6 +8135,10 @@
(aload (compiland-argument-register compiland))
(emit-push-constant-int (variable-index variable))
(emit 'aaload)
+ (emit 'new "org/armedbear/lisp/ClosureBinding")
+ (emit 'dup)
+ (emit-invokespecial-init "org/armedbear/lisp/ClosureBinding"
+ (list "Lorg/armedbear/lisp/LisObject;"))
(emit 'aastore)
(setf (variable-index variable) nil))))
More information about the armedbear-cvs
mailing list