[armedbear-cvs] r11882 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sat May 16 16:44:33 UTC 2009
Author: ehuelsmann
Date: Sat May 16 12:44:29 2009
New Revision: 11882
Log:
Remove the last of the _execute() methods:
By loading the closure array off the 'ctx' slot
in the method, it's no longer required to do
extra function calls just to add it to the
parameter list.
Modified:
trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/ClosureTemplateFunction.java Sat May 16 12:44:29 2009
@@ -62,128 +62,41 @@
}
-
- // execute methods have the semantic meaning
- // "evaluate this object"
- @Override
- public final LispObject execute() throws ConditionThrowable
- {
- return _execute(ctx);
- }
-
- @Override
- public final LispObject execute(LispObject arg) throws ConditionThrowable
- {
- return _execute(ctx, arg);
- }
-
- @Override
- public final LispObject execute(LispObject first, LispObject second)
- throws ConditionThrowable
- {
- return _execute(ctx, first, second);
- }
-
- @Override
- public final LispObject execute(LispObject first, LispObject second,
- LispObject third)
- throws ConditionThrowable
- {
- return _execute(ctx, first, second, third);
- }
-
- @Override
- public final LispObject execute(LispObject first, LispObject second,
- LispObject third, LispObject fourth)
- throws ConditionThrowable
- {
- return _execute(ctx, first, second, third, fourth);
- }
-
- @Override
- public final LispObject execute(LispObject first, LispObject second,
- LispObject third, LispObject fourth,
- LispObject fifth)
- throws ConditionThrowable
- {
- return _execute(ctx, first, second, third, fourth, fifth);
- }
-
- @Override
- public final LispObject execute(LispObject first, LispObject second,
- LispObject third, LispObject fourth,
- LispObject fifth, LispObject sixth)
- throws ConditionThrowable
- {
- return _execute(ctx, first, second, third, fourth, fifth, sixth);
- }
-
- @Override
- public final LispObject execute(LispObject first, LispObject second,
- LispObject third, LispObject fourth,
- LispObject fifth, LispObject sixth,
- LispObject seventh)
- throws ConditionThrowable
- {
- return _execute(ctx, first, second, third, fourth, fifth, sixth, seventh);
- }
-
- @Override
- public final LispObject execute(LispObject first, LispObject second,
- LispObject third, LispObject fourth,
- LispObject fifth, LispObject sixth,
- LispObject seventh, LispObject eighth)
- throws ConditionThrowable
- {
- return _execute(ctx, first, second, third, fourth, fifth,
- sixth, seventh, eighth);
- }
-
- @Override
- public final LispObject execute(LispObject[] args)
- throws ConditionThrowable
- {
- return _execute(ctx, args);
- }
-
private final LispObject notImplemented() throws ConditionThrowable
{
return error(new WrongNumberOfArgumentsException(this));
}
- // _execute methods have the semantic meaning
- // "evaluate this template with these values"
-
// Zero args.
- public LispObject _execute(ClosureBinding[] context) throws ConditionThrowable
+ public LispObject execute() throws ConditionThrowable
{
LispObject[] args = new LispObject[0];
- return _execute(context, args);
+ return execute(args);
}
// One arg.
- public LispObject _execute(ClosureBinding[] context, LispObject first)
+ public LispObject execute( LispObject first)
throws ConditionThrowable
{
LispObject[] args = new LispObject[1];
args[0] = first;
- return _execute(context, args);
+ return execute(args);
}
// Two args.
- public LispObject _execute(ClosureBinding[] context, LispObject first,
+ public LispObject execute( LispObject first,
LispObject second)
throws ConditionThrowable
{
LispObject[] args = new LispObject[2];
args[0] = first;
args[1] = second;
- return _execute(context, args);
+ return execute(args);
}
// Three args.
- public LispObject _execute(ClosureBinding[] context, LispObject first,
+ public LispObject execute( LispObject first,
LispObject second, LispObject third)
throws ConditionThrowable
{
@@ -191,11 +104,11 @@
args[0] = first;
args[1] = second;
args[2] = third;
- return _execute(context, args);
+ return execute(args);
}
// Four args.
- public LispObject _execute(ClosureBinding[] context, LispObject first,
+ public LispObject execute( LispObject first,
LispObject second, LispObject third,
LispObject fourth)
throws ConditionThrowable
@@ -205,11 +118,11 @@
args[1] = second;
args[2] = third;
args[3] = fourth;
- return _execute(context, args);
+ return execute(args);
}
// Five args.
- public LispObject _execute(ClosureBinding[] context, LispObject first,
+ public LispObject execute( LispObject first,
LispObject second, LispObject third,
LispObject fourth, LispObject fifth)
throws ConditionThrowable
@@ -220,11 +133,11 @@
args[2] = third;
args[3] = fourth;
args[4] = fifth;
- return _execute(context, args);
+ return execute(args);
}
// Six args.
- public LispObject _execute(ClosureBinding[] context, LispObject first,
+ public LispObject execute( LispObject first,
LispObject second, LispObject third,
LispObject fourth, LispObject fifth,
LispObject sixth)
@@ -237,11 +150,11 @@
args[3] = fourth;
args[4] = fifth;
args[5] = sixth;
- return _execute(context, args);
+ return execute(args);
}
// Seven args.
- public LispObject _execute(ClosureBinding[] context, LispObject first,
+ public LispObject execute( LispObject first,
LispObject second, LispObject third,
LispObject fourth, LispObject fifth,
LispObject sixth, LispObject seventh)
@@ -255,11 +168,11 @@
args[4] = fifth;
args[5] = sixth;
args[6] = seventh;
- return _execute(context, args);
+ return execute(args);
}
// Eight args.
- public LispObject _execute(ClosureBinding[] context, LispObject first,
+ public LispObject execute( LispObject first,
LispObject second, LispObject third,
LispObject fourth, LispObject fifth,
LispObject sixth, LispObject seventh,
@@ -275,11 +188,11 @@
args[5] = sixth;
args[6] = seventh;
args[7] = eighth;
- return _execute(context, args);
+ return execute(args);
}
// Arg array.
- public LispObject _execute(ClosureBinding[] context, LispObject[] args)
+ public LispObject execute(LispObject[] args)
throws ConditionThrowable
{
return notImplemented();
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 Sat May 16 12:44:29 2009
@@ -7858,31 +7858,13 @@
(setf *using-arg-array* t)
(setf *hairy-arglist-p* t)
(return-from analyze-args
- (if *closure-variables*
- (get-descriptor (list +closure-binding-array+
- +lisp-object-array+)
- +lisp-object+)
- (get-descriptor (list +lisp-object-array+)
- +lisp-object+))))
- (cond (*closure-variables*
- (return-from analyze-args
- (cond ((<= arg-count call-registers-limit)
- (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 +closure-binding-array+ +lisp-object-array+) ;; FIXME
- +lisp-object+)))))
- (t
- (return-from analyze-args
- (cond ((<= arg-count call-registers-limit)
- (get-descriptor (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+))))))) ;; FIXME
+ (get-descriptor (list +lisp-object-array+) +lisp-object+)))
+ (return-from analyze-args
+ (cond ((<= arg-count call-registers-limit)
+ (get-descriptor (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+)))))
(when (or (memq '&KEY args)
(memq '&OPTIONAL args)
(memq '&REST args))
@@ -8016,9 +7998,7 @@
(*child-p* (not (null (compiland-parent compiland))))
(descriptor (analyze-args compiland))
- (execute-method (make-method :name (if (and *child-p*
- *closure-variables*)
- "_execute" "execute")
+ (execute-method (make-method :name "execute"
:descriptor descriptor))
(*code* ())
(*register* 1) ;; register 0: "this" pointer
@@ -8041,12 +8021,6 @@
(setf (method-descriptor-index execute-method)
(pool-name (method-descriptor execute-method)))
- (when (and *closure-variables* *child-p*)
- (setf (compiland-closure-register compiland)
- (allocate-register)) ;; register 1: the closure array
- (dformat t "p2-compiland 1 closure register = ~S~%"
- (compiland-closure-register compiland)))
-
(when *using-arg-array*
(setf (compiland-argument-register compiland) (allocate-register)))
@@ -8064,19 +8038,25 @@
;; Reserve the next available slot for the thread register.
(setf *thread* (allocate-register))
- (when (and *closure-variables* (not *child-p*))
+ (when *closure-variables*
(setf (compiland-closure-register compiland) (allocate-register))
(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 +closure-binding-class+))
- (local-closure-vars
- (duplicate-closure-array compiland))))
+ (if (not *child-p*)
+ (progn
+ ;; if we're the ultimate parent: create the closure array
+ (emit-push-constant-int (length *closure-variables*))
+ (emit 'anewarray +closure-binding-class+))
+ (progn
+ (aload 0)
+ (emit 'getfield +lisp-ctf-class+ "ctx"
+ +closure-binding-array+)
+ (when local-closure-vars
+ ;; in all other cases, it gets stored in the register below
+ (emit 'astore (compiland-closure-register compiland))
+ (duplicate-closure-array compiland)))))
;; Move args from their original registers to the closure variables array
(when (or closure-args
@@ -8117,7 +8097,7 @@
(list +lisp-object+))
(emit 'aastore)))))
- (when (or local-closure-vars (and *closure-variables* (not *child-p*)))
+ (when *closure-variables*
(aver (not (null (compiland-closure-register compiland))))
(astore (compiland-closure-register compiland))
(dformat t "~S done moving arguments to closure array~%"
More information about the armedbear-cvs
mailing list