[armedbear-cvs] r12398 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sun Jan 24 21:59:57 UTC 2010
Author: ehuelsmann
Date: Sun Jan 24 16:59:56 2010
New Revision: 12398
Log:
Move lambda-list analysis from runtime to compile time for compiled functions.
Modified:
trunk/abcl/src/org/armedbear/lisp/Closure.java
trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java
trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/Closure.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/Closure.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/Closure.java Sun Jan 24 16:59:56 2010
@@ -41,11 +41,11 @@
public class Closure extends Function
{
// Parameter types.
- private static final int REQUIRED = 0;
- private static final int OPTIONAL = 1;
- private static final int KEYWORD = 2;
- private static final int REST = 3;
- private static final int AUX = 4;
+ public static final int REQUIRED = 0;
+ public static final int OPTIONAL = 1;
+ public static final int KEYWORD = 2;
+ public static final int REST = 3;
+ public static final int AUX = 4;
// States.
private static final int STATE_REQUIRED = 0;
@@ -75,8 +75,50 @@
private boolean bindInitForms;
- public Closure(LispObject lambdaExpression, Environment env)
+ /** Construct a closure object with a lambda-list described
+ * by these parameters.
+ *
+ *
+ * @param required Required parameters or an empty array for none
+ * @param optional Optional parameters or an empty array for none
+ * @param keyword Keyword parameters or an empty array for none
+ * @param keys NIL if the lambda-list doesn't contain &key, T otherwise
+ * @param rest the &rest parameter, or NIL if none
+ * @param moreKeys NIL if &allow-other-keys not present, T otherwise
+ */
+ public Closure(Parameter[] required,
+ Parameter[] optional,
+ Parameter[] keyword,
+ Symbol keys, Symbol rest, Symbol moreKeys) {
+ minArgs = required.length;
+ maxArgs = (rest == NIL && moreKeys == NIL)
+ ? minArgs + optional.length + 2*keyword.length : -1;
+
+ arity = (rest == NIL && moreKeys == NIL && keys == NIL
+ && optional.length == 0)
+ ? maxArgs : -1;
+
+ requiredParameters = required;
+ optionalParameters = optional;
+ keywordParameters = keyword;
+
+ if (rest != NIL)
+ restVar = rest;
+
+ andKey = keys != NIL;
+ allowOtherKeys = moreKeys != NIL;
+ variables = processVariables();
+ bindInitForms = false;
+
+ // stuff we don't need: we're a compiled function
+ body = null;
+ executionBody = null;
+ environment = null;
+ }
+
+
+ public Closure(LispObject lambdaExpression, Environment env)
{
this(null, lambdaExpression, env);
}
@@ -982,7 +1024,7 @@
}
}
- private static class Parameter
+ public static class Parameter
{
private final Symbol var;
private final LispObject initForm;
Modified: trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java (original)
+++ trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java Sun Jan 24 16:59:56 2010
@@ -41,8 +41,16 @@
public ClosureBinding[] ctx;
- public CompiledClosure(LispObject lambdaList)
+ public CompiledClosure(Parameter[] required,
+ Parameter[] optional,
+ Parameter[] keyword,
+ Symbol keys, Symbol rest, Symbol moreKeys)
+ {
+ super(required, optional, keyword, keys, rest, moreKeys);
+ }
+
+ public CompiledClosure(LispObject lambdaList)
{
super(list(Symbol.LAMBDA, lambdaList), null);
}
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun Jan 24 16:59:56 2010
@@ -58,6 +58,87 @@
;;; Pass 1.
+(defun parse-lambda-list (lambda-list)
+ "Breaks the lambda list into the different elements, returning the values
+
+ required-vars
+ optional-vars
+ key-vars
+ key-p
+ rest-var
+ allow-other-keys-p
+ aux-vars
+ whole-var
+ env-var
+
+where each of the vars returned is a list with these elements:
+
+ var - the actual variable name
+ initform - the init form if applicable; optional, keyword and aux vars
+ p-var - variable indicating presence
+ keyword - the keyword argument to match against
+
+"
+ (let ((state :req)
+ req opt key rest whole env aux key-p allow-others-p)
+ (dolist (arg lambda-list)
+ (case arg
+ (&optional (setf state :opt))
+ (&key (setf state :key
+ key-p t))
+ (&rest (setf state :rest))
+ (&aux (setf state :aux))
+ (&allow-other-keys (setf state :none
+ allow-others-p t))
+ (&whole (setf state :whole))
+ (&environment (setf state :env))
+ (t
+ (case state
+ (:req (push arg req))
+ (:rest (setf rest (list arg)
+ state :none))
+ (:env (setf env (list arg)
+ state :req))
+ (:whole (setf whole (list arg)
+ state :req))
+ (:none
+ (error "Invalid lambda list: argument found in :none state."))
+ (:opt
+ (cond
+ ((symbolp arg)
+ (push (list arg nil nil nil) opt))
+ ((consp arg)
+ (push (list (car arg) (cadr arg) (caddr arg)) opt))
+ (t
+ (error "Invalid state."))))
+ (:aux
+ (cond
+ ((symbolp arg)
+ (push (list arg nil nil nil) aux))
+ ((consp arg)
+ (push (list (car arg) (cadr arg) nil nil) aux))
+ (t
+ (error "Invalid :aux state."))))
+ (:key
+ (cond
+ ((symbolp arg)
+ (push (list arg nil nil (sys::keywordify arg)) key))
+ ((and (consp arg)
+ (consp (car arg)))
+ (push (list (cadar arg) (cadr arg) (caddr arg) (caar arg)) key))
+ ((consp arg)
+ (push (list (car arg) (cadr arg) (caddr arg)
+ (sys::keywordify (car arg))) key))
+ (t
+ (error "Invalid :key state."))))
+ (t (error "Invalid state found."))))))
+ (values
+ (nreverse req)
+ (nreverse opt)
+ (nreverse key)
+ key-p
+ rest allow-others-p
+ (nreverse aux) whole env)))
;; Returns a list of declared free specials, if any are found.
(declaim (ftype (function (list list block-node) list)
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 Sun Jan 24 16:59:56 2010
@@ -253,6 +253,9 @@
(defconstant +lisp-package-class+ "org/armedbear/lisp/Package")
(defconstant +lisp-readtable-class+ "org/armedbear/lisp/Readtable")
(defconstant +lisp-stream-class+ "org/armedbear/lisp/Stream")
+(defconstant +lisp-closure-class+ "org/armedbear/lisp/Closure")
+(defconstant +lisp-closure-parameter-class+ "org/armedbear/lisp/Closure$Parameter")
+(defconstant +lisp-closure-parameter-array+ "[Lorg/armedbear/lisp/Closure$Parameter;")
(defstruct (instruction (:constructor %make-instruction (opcode args)))
(opcode 0 :type (integer 0 255))
@@ -1816,22 +1819,144 @@
(list +java-string+) +lisp-object+))
(emit-push-nil)))
+(defun emit-read-from-string (object)
+ (emit-constructor-lambda-list object))
+
(defun make-constructor (super lambda-name args)
(let* ((*compiler-debug* nil)
;; We don't normally need to see debugging output for constructors.
(constructor (make-method :name "<init>"
:descriptor "()V"))
+ req-params-register
+ opt-params-register
+ key-params-register
+ rest-p
+ keys-p
+ more-keys-p
(*code* ())
(*handlers* nil))
(setf (method-max-locals constructor) 1)
+ (unless (equal super +lisp-primitive-class+)
+ (multiple-value-bind
+ (req opt key key-p rest
+ allow-other-keys-p)
+ (parse-lambda-list args)
+ (setf rest-p rest
+ more-keys-p allow-other-keys-p
+ keys-p key-p)
+ (when t
+ ;; process required args
+ (emit-push-constant-int (length req))
+ (emit 'anewarray +lisp-closure-parameter-class+)
+ (astore (setf req-params-register (method-max-locals constructor)))
+ (incf (method-max-locals constructor))
+ (do ((i 0 (1+ i))
+ (req req (cdr req)))
+ ((endp req))
+ (aload req-params-register)
+ (emit-push-constant-int i)
+ (emit 'new +lisp-closure-parameter-class+)
+ (emit 'dup)
+ (emit-push-t) ;; we don't need the actual symbol
+ (emit-invokespecial-init +lisp-closure-parameter-class+
+ (list +lisp-symbol+))
+ (emit 'aastore)))
+ (when t
+ ;; process optional args
+ (emit-push-constant-int (length opt))
+ (emit 'anewarray +lisp-closure-parameter-class+)
+ (astore (setf opt-params-register (method-max-locals constructor)))
+ (incf (method-max-locals constructor))
+ (do ((i 0 (1+ i))
+ (opt opt (cdr opt)))
+ ((endp opt))
+ (aload opt-params-register)
+ (emit-push-constant-int i)
+ (emit 'new +lisp-closure-parameter-class+)
+ (emit 'dup)
+ (emit-push-t) ;; we don't need the actual variable-symbol
+ (emit-read-from-string (second (car opt))) ;; initform
+ (if (null (third (car opt))) ;;
+ (emit-push-nil)
+ (emit-push-t)) ;; we don't need the actual supplied-p symbol
+ (emit 'getstatic +lisp-closure-class+ "OPTIONAL" "I")
+ (emit-invokespecial-init +lisp-closure-parameter-class+
+ (list +lisp-symbol+ +lisp-object+
+ +lisp-object+ "I"))
+ (emit 'aastore)))
+ (when t
+ ;; process key args
+ (emit-push-constant-int (length key))
+ (emit 'anewarray +lisp-closure-parameter-class+)
+ (astore (setf key-params-register (method-max-locals constructor)))
+ (incf (method-max-locals constructor))
+ (do ((i 0 (1+ i))
+ (key key (cdr key)))
+ ((endp key))
+ (aload key-params-register)
+ (emit-push-constant-int i)
+ (emit 'new +lisp-closure-parameter-class+)
+ (emit 'dup)
+ (let ((keyword (fourth (car key))))
+ (if (keywordp keyword)
+ (progn
+ (emit 'ldc (pool-string (symbol-name keyword)))
+ (emit-invokestatic +lisp-class+ "internKeyword"
+ (list +java-string+) +lisp-symbol+))
+ ;; symbol is not really a keyword; yes, that's allowed!
+ (progn
+ (emit 'ldc (pool-string (symbol-name keyword)))
+ (emit 'ldc (pool-string
+ (package-name (symbol-package keyword))))
+ (emit-invokestatic +lisp-class+ "internInPackage"
+ (list +java-string+ +java-string+)
+ +lisp-symbol+))))
+ (emit-push-t) ;; we don't need the actual variable-symbol
+ (emit-read-from-string (second (car key)))
+ (if (null (third (car key)))
+ (emit-push-nil)
+ (emit-push-t)) ;; we don't need the actual supplied-p symbol
+ (emit-invokespecial-init +lisp-closure-parameter-class+
+ (list +lisp-symbol+ +lisp-symbol+
+ +lisp-object+ +lisp-object+))
+ (emit 'aastore)))
+
+ ))
(aload 0) ;; this
(cond ((equal super +lisp-primitive-class+)
(emit-constructor-lambda-name lambda-name)
(emit-constructor-lambda-list args)
(emit-invokespecial-init super (lisp-object-arg-types 2)))
- ((equal super +lisp-compiled-closure-class+)
+ ((and (null req-params-register)
+ (equal super +lisp-compiled-closure-class+))
(emit-constructor-lambda-list args)
(emit-invokespecial-init super (lisp-object-arg-types 1)))
+ ((and
+ (equal super +lisp-compiled-closure-class+))
+ (aload req-params-register)
+ (aload opt-params-register)
+ (aload key-params-register)
+ (if keys-p
+ (emit-push-t)
+ (progn
+ (emit-push-nil)
+ (emit 'checkcast +lisp-symbol-class+)))
+ (if rest-p
+ (emit-push-t)
+ (progn
+ (emit-push-nil)
+ (emit 'checkcast +lisp-symbol-class+)))
+ (if more-keys-p
+ (emit-push-t)
+ (progn
+ (emit-push-nil)
+ (emit 'checkcast +lisp-symbol-class+)))
+ (emit-invokespecial-init super
+ (list +lisp-closure-parameter-array+
+ +lisp-closure-parameter-array+
+ +lisp-closure-parameter-array+
+ +lisp-symbol+
+ +lisp-symbol+ +lisp-symbol+)))
(t
(aver nil)))
(setf *code* (append *static-code* *code*))
More information about the armedbear-cvs
mailing list