Changeset 12398


Ignore:
Timestamp:
01/24/10 21:59:56 (11 years ago)
Author:
ehuelsmann
Message:

Move lambda-list analysis from runtime to compile time for compiled functions.

Location:
trunk/abcl/src/org/armedbear/lisp
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/Closure.java

    r12394 r12398  
    4242{
    4343  // Parameter types.
    44   private static final int REQUIRED = 0;
    45   private static final int OPTIONAL = 1;
    46   private static final int KEYWORD  = 2;
    47   private static final int REST     = 3;
    48   private static final int AUX      = 4;
     44  public static final int REQUIRED = 0;
     45  public static final int OPTIONAL = 1;
     46  public static final int KEYWORD  = 2;
     47  public static final int REST     = 3;
     48  public static final int AUX      = 4;
    4949
    5050  // States.
     
    7676  private boolean bindInitForms;
    7777
     78
     79    /** Construct a closure object with a lambda-list described
     80     * by these parameters.
     81     *
     82     *
     83     * @param required Required parameters or an empty array for none
     84     * @param optional Optional parameters or an empty array for none
     85     * @param keyword Keyword parameters or an empty array for none
     86     * @param keys NIL if the lambda-list doesn't contain &key, T otherwise
     87     * @param rest the &rest parameter, or NIL if none
     88     * @param moreKeys NIL if &allow-other-keys not present, T otherwise
     89     */
     90  public Closure(Parameter[] required,
     91                 Parameter[] optional,
     92                 Parameter[] keyword,
     93                 Symbol keys, Symbol rest, Symbol moreKeys) {
     94      minArgs = required.length;
     95      maxArgs = (rest == NIL && moreKeys == NIL)
     96          ? minArgs + optional.length + 2*keyword.length : -1;
     97
     98      arity = (rest == NIL && moreKeys == NIL && keys == NIL
     99               && optional.length == 0)
     100          ? maxArgs : -1;
     101
     102      requiredParameters = required;
     103      optionalParameters = optional;
     104      keywordParameters = keyword;
     105
     106      if (rest != NIL)
     107        restVar = rest;
     108
     109      andKey = keys != NIL;
     110      allowOtherKeys = moreKeys != NIL;
     111      variables = processVariables();
     112      bindInitForms = false;
     113
     114      // stuff we don't need: we're a compiled function
     115      body = null;
     116      executionBody = null;
     117      environment = null;
     118  }
     119
     120
    78121  public Closure(LispObject lambdaExpression, Environment env)
    79 
    80122  {
    81123    this(null, lambdaExpression, env);
     
    9831025  }
    9841026
    985   private static class Parameter
     1027  public static class Parameter
    9861028  {
    9871029    private final Symbol var;
  • trunk/abcl/src/org/armedbear/lisp/CompiledClosure.java

    r12306 r12398  
    4242  public ClosureBinding[] ctx;
    4343
     44  public CompiledClosure(Parameter[] required,
     45                         Parameter[] optional,
     46                         Parameter[] keyword,
     47                         Symbol keys, Symbol rest, Symbol moreKeys)
     48  {
     49      super(required, optional, keyword, keys, rest, moreKeys);
     50  }
     51
     52
    4453  public CompiledClosure(LispObject lambdaList)
    45 
    4654  {
    4755    super(list(Symbol.LAMBDA, lambdaList), null);
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

    r12174 r12398  
    5959;;; Pass 1.
    6060
     61(defun parse-lambda-list (lambda-list)
     62  "Breaks the lambda list into the different elements, returning the values
     63
     64 required-vars
     65 optional-vars
     66 key-vars
     67 key-p
     68 rest-var
     69 allow-other-keys-p
     70 aux-vars
     71 whole-var
     72 env-var
     73
     74where each of the vars returned is a list with these elements:
     75
     76 var      - the actual variable name
     77 initform - the init form if applicable; optional, keyword and aux vars
     78 p-var    - variable indicating presence
     79 keyword  - the keyword argument to match against
     80
     81"
     82  (let ((state :req)
     83        req opt key rest whole env aux key-p allow-others-p)
     84    (dolist (arg lambda-list)
     85      (case arg
     86        (&optional (setf state :opt))
     87        (&key (setf state :key
     88                    key-p t))
     89        (&rest (setf state :rest))
     90        (&aux (setf state :aux))
     91        (&allow-other-keys (setf state :none
     92                                 allow-others-p t))
     93        (&whole (setf state :whole))
     94        (&environment (setf state :env))
     95        (t
     96         (case state
     97           (:req (push arg req))
     98           (:rest (setf rest (list arg)
     99                        state :none))
     100           (:env (setf env (list arg)
     101                       state :req))
     102           (:whole (setf whole (list arg)
     103                         state :req))
     104           (:none
     105            (error "Invalid lambda list: argument found in :none state."))
     106           (:opt
     107            (cond
     108              ((symbolp arg)
     109               (push (list arg nil nil nil) opt))
     110              ((consp arg)
     111               (push (list (car arg) (cadr arg) (caddr arg)) opt))
     112              (t
     113               (error "Invalid state."))))
     114           (:aux
     115            (cond
     116              ((symbolp arg)
     117               (push (list arg nil nil nil) aux))
     118              ((consp arg)
     119               (push (list (car arg) (cadr arg) nil nil) aux))
     120              (t
     121               (error "Invalid :aux state."))))
     122           (:key
     123            (cond
     124              ((symbolp arg)
     125               (push (list arg nil nil (sys::keywordify arg)) key))
     126              ((and (consp arg)
     127                    (consp (car arg)))
     128               (push (list (cadar arg) (cadr arg) (caddr arg) (caar arg)) key))
     129              ((consp arg)
     130               (push (list (car arg) (cadr arg) (caddr arg)
     131                           (sys::keywordify (car arg))) key))
     132              (t
     133               (error "Invalid :key state."))))
     134           (t (error "Invalid state found."))))))
     135    (values
     136     (nreverse req)
     137     (nreverse opt)
     138     (nreverse key)
     139     key-p
     140     rest allow-others-p
     141     (nreverse aux) whole env)))
    61142
    62143;; Returns a list of declared free specials, if any are found.
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

    r12311 r12398  
    254254(defconstant +lisp-readtable-class+ "org/armedbear/lisp/Readtable")
    255255(defconstant +lisp-stream-class+ "org/armedbear/lisp/Stream")
     256(defconstant +lisp-closure-class+ "org/armedbear/lisp/Closure")
     257(defconstant +lisp-closure-parameter-class+ "org/armedbear/lisp/Closure$Parameter")
     258(defconstant +lisp-closure-parameter-array+ "[Lorg/armedbear/lisp/Closure$Parameter;")
    256259
    257260(defstruct (instruction (:constructor %make-instruction (opcode args)))
     
    18171820      (emit-push-nil)))
    18181821
     1822(defun emit-read-from-string (object)
     1823  (emit-constructor-lambda-list object))
     1824
    18191825(defun make-constructor (super lambda-name args)
    18201826  (let* ((*compiler-debug* nil)
     
    18221828         (constructor (make-method :name "<init>"
    18231829                                   :descriptor "()V"))
     1830         req-params-register
     1831         opt-params-register
     1832         key-params-register
     1833         rest-p
     1834         keys-p
     1835         more-keys-p
    18241836         (*code* ())
    18251837         (*handlers* nil))
    18261838    (setf (method-max-locals constructor) 1)
     1839    (unless (equal super +lisp-primitive-class+)
     1840      (multiple-value-bind
     1841            (req opt key key-p rest
     1842                 allow-other-keys-p)
     1843          (parse-lambda-list args)
     1844        (setf rest-p rest
     1845              more-keys-p allow-other-keys-p
     1846              keys-p key-p)
     1847        (when t
     1848          ;; process required args
     1849          (emit-push-constant-int (length req))
     1850          (emit 'anewarray +lisp-closure-parameter-class+)
     1851          (astore (setf req-params-register (method-max-locals constructor)))
     1852          (incf (method-max-locals constructor))
     1853          (do ((i 0 (1+ i))
     1854               (req req (cdr req)))
     1855              ((endp req))
     1856            (aload req-params-register)
     1857            (emit-push-constant-int i)
     1858            (emit 'new +lisp-closure-parameter-class+)
     1859            (emit 'dup)
     1860            (emit-push-t) ;; we don't need the actual symbol
     1861            (emit-invokespecial-init +lisp-closure-parameter-class+
     1862                                     (list +lisp-symbol+))
     1863            (emit 'aastore)))
     1864        (when t
     1865          ;; process optional args
     1866          (emit-push-constant-int (length opt))
     1867          (emit 'anewarray +lisp-closure-parameter-class+)
     1868          (astore (setf opt-params-register (method-max-locals constructor)))
     1869          (incf (method-max-locals constructor))
     1870          (do ((i 0 (1+ i))
     1871               (opt opt (cdr opt)))
     1872              ((endp opt))
     1873            (aload opt-params-register)
     1874            (emit-push-constant-int i)
     1875            (emit 'new +lisp-closure-parameter-class+)
     1876            (emit 'dup)
     1877            (emit-push-t) ;; we don't need the actual variable-symbol
     1878            (emit-read-from-string (second (car opt))) ;; initform
     1879            (if (null (third (car opt)))      ;;
     1880                (emit-push-nil)
     1881                (emit-push-t)) ;; we don't need the actual supplied-p symbol
     1882            (emit 'getstatic +lisp-closure-class+ "OPTIONAL" "I")
     1883            (emit-invokespecial-init +lisp-closure-parameter-class+
     1884                                     (list +lisp-symbol+ +lisp-object+
     1885                                           +lisp-object+ "I"))
     1886            (emit 'aastore)))
     1887        (when t
     1888          ;; process key args
     1889          (emit-push-constant-int (length key))
     1890          (emit 'anewarray +lisp-closure-parameter-class+)
     1891          (astore (setf key-params-register (method-max-locals constructor)))
     1892          (incf (method-max-locals constructor))
     1893          (do ((i 0 (1+ i))
     1894               (key key (cdr key)))
     1895              ((endp key))
     1896            (aload key-params-register)
     1897            (emit-push-constant-int i)
     1898            (emit 'new +lisp-closure-parameter-class+)
     1899            (emit 'dup)
     1900            (let ((keyword (fourth (car key))))
     1901              (if (keywordp keyword)
     1902                  (progn
     1903                    (emit 'ldc (pool-string (symbol-name keyword)))
     1904                    (emit-invokestatic +lisp-class+ "internKeyword"
     1905                                       (list +java-string+) +lisp-symbol+))
     1906                  ;; symbol is not really a keyword; yes, that's allowed!
     1907                  (progn
     1908                    (emit 'ldc (pool-string (symbol-name keyword)))
     1909                    (emit 'ldc (pool-string
     1910                                (package-name (symbol-package keyword))))
     1911                    (emit-invokestatic +lisp-class+ "internInPackage"
     1912                                       (list +java-string+ +java-string+)
     1913                                       +lisp-symbol+))))
     1914            (emit-push-t) ;; we don't need the actual variable-symbol
     1915            (emit-read-from-string (second (car key)))
     1916            (if (null (third (car key)))
     1917                (emit-push-nil)
     1918                (emit-push-t)) ;; we don't need the actual supplied-p symbol
     1919            (emit-invokespecial-init +lisp-closure-parameter-class+
     1920                                     (list +lisp-symbol+ +lisp-symbol+
     1921                                           +lisp-object+ +lisp-object+))
     1922            (emit 'aastore)))
     1923
     1924        ))
    18271925    (aload 0) ;; this
    18281926    (cond ((equal super +lisp-primitive-class+)
     
    18301928           (emit-constructor-lambda-list args)
    18311929           (emit-invokespecial-init super (lisp-object-arg-types 2)))
    1832           ((equal super +lisp-compiled-closure-class+)
     1930          ((and (null req-params-register)
     1931                (equal super +lisp-compiled-closure-class+))
    18331932           (emit-constructor-lambda-list args)
    18341933           (emit-invokespecial-init super (lisp-object-arg-types 1)))
     1934          ((and
     1935                (equal super +lisp-compiled-closure-class+))
     1936           (aload req-params-register)
     1937           (aload opt-params-register)
     1938           (aload key-params-register)
     1939           (if keys-p
     1940               (emit-push-t)
     1941               (progn
     1942                 (emit-push-nil)
     1943                 (emit 'checkcast +lisp-symbol-class+)))
     1944           (if rest-p
     1945               (emit-push-t)
     1946               (progn
     1947                 (emit-push-nil)
     1948                 (emit 'checkcast +lisp-symbol-class+)))
     1949           (if more-keys-p
     1950               (emit-push-t)
     1951               (progn
     1952                 (emit-push-nil)
     1953                 (emit 'checkcast +lisp-symbol-class+)))
     1954           (emit-invokespecial-init super
     1955                                    (list +lisp-closure-parameter-array+
     1956                                          +lisp-closure-parameter-array+
     1957                                          +lisp-closure-parameter-array+
     1958                                          +lisp-symbol+
     1959                                          +lisp-symbol+ +lisp-symbol+)))
    18351960          (t
    18361961           (aver nil)))
Note: See TracChangeset for help on using the changeset viewer.