Changeset 8335


Ignore:
Timestamp:
01/10/05 17:46:04 (17 years ago)
Author:
piso
Message:

Merged compiler changes (new implementation of local functions and lexical closures).

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

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/ClosureTemplateFunction.java

    r8139 r8335  
    22 * ClosureTemplateFunction.java
    33 *
    4  * Copyright (C) 2004 Peter Graves
    5  * $Id: ClosureTemplateFunction.java,v 1.4 2004-11-07 18:06:05 piso Exp $
     4 * Copyright (C) 2004-2005 Peter Graves
     5 * $Id: ClosureTemplateFunction.java,v 1.5 2005-01-10 17:46:03 piso Exp $
    66 *
    77 * This program is free software; you can redistribute it and/or
     
    2828    {
    2929        super(lambdaList, NIL, null);
     30    }
     31
     32    public ClosureTemplateFunction(Symbol symbol, LispObject lambdaList,
     33                                   LispObject body, Environment env)
     34        throws ConditionThrowable
     35    {
     36        super(null, lambdaList, body, env);
    3037    }
    3138
     
    6067    }
    6168
    62     public final LispObject execute(LispObject[] args) throws ConditionThrowable
    63     {
    64         return notImplemented();
    65     }
    66 
    6769    private static final LispObject notImplemented() throws ConditionThrowable
    6870    {
     
    7072    }
    7173
    72     public abstract LispObject execute(LispObject[] args, LispObject[][] context)
    73         throws ConditionThrowable;
     74    // Zero args.
     75    public LispObject execute(LispObject[] context) throws ConditionThrowable
     76    {
     77        LispObject[] args = new LispObject[0];
     78        return execute(context, args);
     79    }
     80
     81    // One arg.
     82    public LispObject execute(LispObject[] context, LispObject first)
     83        throws ConditionThrowable
     84    {
     85        LispObject[] args = new LispObject[1];
     86        args[0] = first;
     87        return execute(context, args);
     88    }
     89
     90    // Two args.
     91    public LispObject execute(LispObject[] context, LispObject first,
     92                              LispObject second)
     93        throws ConditionThrowable
     94    {
     95        LispObject[] args = new LispObject[2];
     96        args[0] = first;
     97        args[1] = second;
     98        return execute(context, args);
     99    }
     100
     101    // Three args.
     102    public LispObject execute(LispObject[] context, LispObject first,
     103                              LispObject second, LispObject third)
     104        throws ConditionThrowable
     105    {
     106        LispObject[] args = new LispObject[3];
     107        args[0] = first;
     108        args[1] = second;
     109        args[2] = third;
     110        return execute(context, args);
     111    }
     112
     113    // Four args.
     114    public LispObject execute(LispObject[] context, LispObject first,
     115                              LispObject second, LispObject third,
     116                              LispObject fourth)
     117        throws ConditionThrowable
     118    {
     119        LispObject[] args = new LispObject[4];
     120        args[0] = first;
     121        args[1] = second;
     122        args[2] = third;
     123        args[3] = fourth;
     124        return execute(context, args);
     125    }
     126
     127    // Arg array.
     128    public LispObject execute(LispObject[] context, LispObject[] args)
     129        throws ConditionThrowable
     130    {
     131        return notImplemented();
     132    }
    74133}
  • trunk/j/src/org/armedbear/lisp/CompiledClosure.java

    r7284 r8335  
    22 * CompiledClosure.java
    33 *
    4  * Copyright (C) 2004 Peter Graves
    5  * $Id: CompiledClosure.java,v 1.2 2004-07-21 18:10:05 piso Exp $
     4 * Copyright (C) 2004-2005 Peter Graves
     5 * $Id: CompiledClosure.java,v 1.3 2005-01-10 17:46:03 piso Exp $
    66 *
    77 * This program is free software; you can redistribute it and/or
     
    2525{
    2626    private final ClosureTemplateFunction ctf;
    27     private final LispObject[][] context;
     27    private final LispObject[] context;
    2828
    29     public CompiledClosure(ClosureTemplateFunction ctf, LispObject[][] context)
     29    public CompiledClosure(ClosureTemplateFunction ctf, LispObject[] context)
    3030    {
    3131        this.ctf = ctf;
     
    4141    public LispObject execute() throws ConditionThrowable
    4242    {
    43         LispObject[] args = new LispObject[0];
    44         return ctf.execute(args, context);
     43        return ctf.execute(context);
    4544    }
    4645
    4746    public LispObject execute(LispObject arg) throws ConditionThrowable
    4847    {
    49         LispObject[] args = new LispObject[1];
    50         args[0] = arg;
    51         return ctf.execute(args, context);
     48        return ctf.execute(context, arg);
    5249    }
    5350
     
    5552        throws ConditionThrowable
    5653    {
    57         LispObject[] args = new LispObject[2];
    58         args[0] = first;
    59         args[1] = second;
    60         return ctf.execute(args, context);
     54        return ctf.execute(context, first, second);
    6155    }
    6256
     
    6559        throws ConditionThrowable
    6660    {
    67         LispObject[] args = new LispObject[3];
    68         args[0] = first;
    69         args[1] = second;
    70         args[2] = third;
    71         return ctf.execute(args, context);
     61        return ctf.execute(context, first, second, third);
    7262    }
    7363
     
    7666        throws ConditionThrowable
    7767    {
    78         LispObject[] args = new LispObject[4];
    79         args[0] = first;
    80         args[1] = second;
    81         args[2] = third;
    82         args[3] = fourth;
    83         return ctf.execute(args, context);
     68        return ctf.execute(context, first, second, third, fourth);
    8469    }
    8570
    8671    public LispObject execute(LispObject[] args) throws ConditionThrowable
    8772    {
    88         return ctf.execute(args, context);
     73        return ctf.execute(context, args);
    8974    }
    9075}
  • trunk/j/src/org/armedbear/lisp/Lisp.java

    r8277 r8335  
    22 * Lisp.java
    33 *
    4  * Copyright (C) 2002-2004 Peter Graves
    5  * $Id: Lisp.java,v 1.307 2004-12-21 14:52:29 piso Exp $
     4 * Copyright (C) 2002-2005 Peter Graves
     5 * $Id: Lisp.java,v 1.308 2005-01-10 17:46:03 piso Exp $
    66 *
    77 * This program is free software; you can redistribute it and/or
     
    800800
    801801    public static final LispObject makeCompiledClosure(LispObject ctf,
    802                                                        LispObject[][] context)
     802                                                       LispObject[] context)
    803803    {
    804804        return new CompiledClosure((ClosureTemplateFunction)ctf, context);
  • trunk/j/src/org/armedbear/lisp/jvm.lisp

    r8327 r8335  
    11;;; jvm.lisp
    22;;;
    3 ;;; Copyright (C) 2003-2004 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.342 2005-01-03 03:14:48 piso Exp $
     3;;; Copyright (C) 2003-2005 Peter Graves
     4;;; $Id: jvm.lisp,v 1.343 2005-01-10 17:46:04 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    3939(defparameter *trust-user-type-declarations* t)
    4040
     41(defvar *closure-variables* nil)
     42
    4143(defvar *enable-dformat* nil)
    4244
     
    6769  `(defun ,@args))
    6870
    69 (defvar *use-locals-vector* nil)
     71;; (defvar *use-locals-vector* nil)
    7072
    7173(defvar *compiler-debug* nil)
     
    8082  (children 0) ; Number of local functions defined with FLET or LABELS.
    8183  contains-lambda
     84  argument-register
     85  closure-register
    8286  )
    8387
     
    153157  (level *nesting-level*)
    154158  index
     159  closure-index
    155160  (reads 0)
    156161  (writes 0)
     
    184189(defvar *child-count* 0)
    185190
    186 (defvar *context* nil)
    187 
    188 (defvar *context-register* nil)
    189 
    190 (defstruct context vars)
    191 
    192 (defun add-variable-to-context (variable)
    193   (aver (variable-p variable))
    194   (push variable (context-vars *context*)))
    195 
    196 (defun push-variable (name special-p)
    197   (let* ((index (if special-p nil (length (context-vars *context*))))
    198          (variable (make-variable :name name :special-p special-p :index index)))
    199     (push variable *visible-variables*)
    200 ;;     (push variable *all-variables*)
    201     (unless special-p
    202       (add-variable-to-context variable))
    203     variable))
     191;; (defvar *context* nil)
     192
     193;; (defstruct context vars)
     194
     195;; (defun add-variable-to-context (variable)
     196;;   (aver (variable-p variable))
     197;;   (push variable (context-vars *context*)))
    204198
    205199(defun find-visible-variable (name)
     
    226220(defstruct local-function
    227221  name
     222  compiland
    228223  function
    229224  classfile
     
    233228(defvar *local-functions* ())
    234229
    235 (defsubst find-local-function (name)
     230(defun find-local-function (name)
    236231  (find name *local-functions* :key #'local-function-name))
    237232
     
    329324            (return nil))))
    330325    (let ((vars (if (eq op 'LET) (p1-let-vars varlist) (p1-let*-vars varlist))))
     326      (dformat t "p1-let/let* vars = ~S~%" (mapcar #'variable-name vars))
    331327      ;; Check for globally declared specials.
    332328      (dolist (variable vars)
     
    438434  form)
    439435
    440 (defun p1-flet/labels (form)
    441   (when *current-compiland*
    442     (incf (compiland-children *current-compiland*) (length (cadr form))))
     436(defun p1-flet (form)
     437;;   (when *current-compiland*
     438    (incf (compiland-children *current-compiland*) (length (cadr form)))
     439;;     )
    443440  (let ((*current-compiland* *current-compiland*)
    444441        (compilands ()))
     
    458455            (p1-compiland compiland)))
    459456        (push compiland compilands)))
    460 
    461 ;;     (list* (car form) (cadr form) (mapcar #'p1 (cddr form))))
    462457  (list* (car form) (nreverse compilands) (mapcar #'p1 (cddr form)))))
    463458
     459(defun p1-labels (form)
     460  (incf (compiland-children *current-compiland*) (length (cadr form)))
     461  (let ((*visible-variables* *visible-variables*)
     462        (*local-functions* *local-functions*)
     463        (*current-compiland* *current-compiland*)
     464        (local-functions ()))
     465    (dolist (definition (cadr form))
     466      (let* ((name (car definition))
     467             (lambda-list (cadr definition))
     468             (body (cddr definition))
     469             (compiland (make-compiland :name name
     470                                        :parent *current-compiland*))
     471             (variable (make-variable :name (copy-symbol name)))
     472             (local-function (make-local-function :name name
     473                                                  :compiland compiland
     474                                                  :variable variable)))
     475        (multiple-value-bind (body decls)
     476          (sys::parse-body body)
     477          (setf (compiland-lambda-expression compiland)
     478                `(lambda ,lambda-list ,@decls (block ,name ,@body))))
     479        (push variable *all-variables*)
     480        (push local-function local-functions)))
     481    (setf local-functions (nreverse local-functions))
     482    ;; Make the local functions visible.
     483    (dolist (local-function local-functions)
     484      (push local-function *local-functions*)
     485      (push (local-function-variable local-function) *visible-variables*))
     486    (dolist (local-function local-functions)
     487      (let ((*visible-variables* *visible-variables*)
     488            (*nesting-level* (1+ *nesting-level*))
     489            (*current-compiland* (local-function-compiland local-function)))
     490        (p1-compiland (local-function-compiland local-function))))
     491    (list* (car form) local-functions (mapcar #'p1 (cddr form)))))
     492
    464493(defun p1-function (form)
    465   (if (and (consp (cadr form)) (eq (caadr form) 'LAMBDA))
    466       (list 'FUNCTION (p1 (cadr form)))
    467       form))
    468 
    469 (defun p1-eval-when (form)
    470   (list* (car form) (cadr form) (mapcar #'p1 (cddr form))))
     494  (cond
     495   ((and (consp (cadr form)) (eq (caadr form) 'LAMBDA))
     496    (when *current-compiland*
     497      (incf (compiland-children *current-compiland*)))
     498    (let* ((*current-compiland* *current-compiland*)
     499           (lambda-form (cadr form))
     500           (lambda-list (cadr lambda-form))
     501           (body (cddr lambda-form))
     502           (compiland (make-compiland :name (gensym "ANONYMOUS-LAMBDA-")
     503                                      :lambda-expression lambda-form
     504                                      :parent *current-compiland*)))
     505      (multiple-value-bind (body decls)
     506        (sys::parse-body body)
     507        (setf (compiland-lambda-expression compiland)
     508              `(lambda ,lambda-list ,@decls (block nil ,@body)))
     509        (let ((*visible-variables* *visible-variables*)
     510              (*nesting-level* (1+ *nesting-level*))
     511              (*current-compiland* compiland))
     512          (p1-compiland compiland)))
     513      (list 'FUNCTION compiland)))
     514   (t
     515    form)))
    471516
    472517(defun p1-lambda (form)
    473   (aver (eq (car form) 'LAMBDA))
    474   (when *current-compiland*
    475     (aver (compiland-p *current-compiland*))
    476     (unless (or (compiland-contains-lambda *current-compiland*)
    477                 (eq form (compiland-lambda-expression *current-compiland*)))
    478       (do ((compiland *current-compiland* (compiland-parent compiland)))
    479           ((null compiland))
    480         (setf (compiland-contains-lambda compiland) t))))
    481518  (let* ((lambda-list (cadr form))
    482519         (body (cddr form))
     
    485522      (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
    486523      (setf body (list (append (list 'LET* (cdr auxvars)) body))))
    487     (list* 'LAMBDA lambda-list (mapcar #'p1 body))))
     524    (p1-function (list 'FUNCTION (list* 'LAMBDA lambda-list body)))))
     525
     526(defun p1-eval-when (form)
     527  (list* (car form) (cadr form) (mapcar #'p1 (cddr form))))
    488528
    489529(defun p1-quote (form)
     
    575615                (dformat t "p1: read ~S~%" form))
    576616               (t
    577                 (dformat t "p1: non-local read ~S~%" form)
     617                (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%"
     618                         form
     619                         (compiland-name (variable-compiland variable))
     620                         (compiland-name *current-compiland*))
    578621                (setf (variable-used-non-locally-p variable) t))))
    579622            (dformat t "p1: unknown variable ~S~%" form)))
     
    595638                    (let ((new-form (rewrite-function-call form)))
    596639                      (when (neq new-form form)
     640                        (dformat t "old form = ~S~%" form)
     641                        (dformat t "new form = ~S~%" new-form)
    597642                        (return-from p1 (p1 new-form))))
    598643                    (let ((source-transform (source-transform op)))
     
    604649                      (when expansion
    605650                        (return-from p1 (p1 (expand-inline form expansion)))))
    606                     (p1-default form))))
     651;;                     (p1-default form)
     652                    (let ((local-function (find-local-function op)))
     653                      (when local-function
     654                        (dformat t "p1 local function ~S~%" op)
     655                        (let ((variable (local-function-variable local-function)))
     656                          (when variable
     657                            (unless (eq (variable-compiland variable) *current-compiland*)
     658                              (dformat t "p1 ~S used non-locally~%" (variable-name variable))
     659                              (setf (variable-used-non-locally-p variable) t))))))
     660                    (list* op (mapcar #'p1 (cdr form)))
     661                    )))
    607662            ((and (consp op) (eq (car op) 'LAMBDA))
    608              (unless (and *current-compiland*
    609                           (compiland-contains-lambda *current-compiland*))
    610                (do ((compiland *current-compiland* (compiland-parent compiland)))
    611                    ((null compiland))
    612                  (setf (compiland-contains-lambda compiland) t)))
    613              form)
     663             (p1 (list* 'FUNCALL form)))
    614664            (t
    615665             form))))))
     
    622672(install-p1-handler 'declare              'identity)
    623673(install-p1-handler 'eval-when            'p1-eval-when)
    624 (install-p1-handler 'flet                 'p1-flet/labels)
     674(install-p1-handler 'flet                 'p1-flet)
    625675(install-p1-handler 'function             'p1-function)
    626676(install-p1-handler 'go                   'p1-go)
    627677(install-p1-handler 'if                   'p1-default)
    628 (install-p1-handler 'labels               'p1-flet/labels)
     678(install-p1-handler 'labels               'p1-labels)
    629679(install-p1-handler 'lambda               'p1-lambda)
    630680(install-p1-handler 'let                  'p1-let/let*)
     
    775825(defconstant +lisp-return-class+ "org/armedbear/lisp/Return")
    776826(defconstant +lisp-go-class+ "org/armedbear/lisp/Go")
     827(defconstant +lisp-ctf-class+ "org/armedbear/lisp/ClosureTemplateFunction")
    777828
    778829(defsubst emit-push-nil ()
     
    13821433                (target (second instruction-args))
    13831434                (representation (third instruction-args)))
    1384 ;;            (%format t "resolve-variables name = ~S representation = ~S~%"
    1385 ;;                     (variable-name variable) representation)
    1386 ;;            (%format t "variable-representation = ~S~%"
    1387 ;;                     (variable-representation variable))
    13881435           (aver (variable-p variable))
    13891436           (cond
    1390 ;;             ((eq (variable-representation variable) :unboxed-fixnum)
    1391 ;;              (%format t "resolve-variables constructing boxed fixnum for ~S~%"
    1392 ;;                       (variable-name variable))
    1393 ;;              (emit 'new +lisp-fixnum-class+)
    1394 ;;              (emit 'dup)
    1395 ;;              (emit 'iload (variable-register variable))
    1396 ;;              (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)
    1397 ;;              (emit-move-from-stack target))
    13981437            ((variable-register variable)
     1438             (dformat t "variable = ~S register = ~S~%"
     1439                      (variable-name variable)
     1440                      (variable-register variable))
    13991441             (emit 'aload (variable-register variable))
    14001442             (emit-move-from-stack target))
    14011443            ((variable-special-p variable)
    14021444             (compile-special-reference (variable-name variable) target nil))
    1403             ((= (variable-level variable) *nesting-level* 0)
    1404              (emit 'aload 1)
    1405              (aver (variable-index variable))
    1406              (emit 'bipush (variable-index variable))
     1445            ((variable-closure-index variable)
     1446             (dformat t "variable = ~S closure-index = ~S~%"
     1447                      (variable-name variable) (variable-closure-index variable))
     1448             (aver (not (null (compiland-closure-register *current-compiland*))))
     1449             (emit 'aload (compiland-closure-register *current-compiland*))
     1450             (emit 'bipush (variable-closure-index variable))
    14071451             (emit 'aaload)
    14081452             (emit-move-from-stack target))
    1409             ((and (variable-index variable) ; A local at the current nesting level.
    1410                   (= (variable-level variable) *nesting-level*))
    1411              (emit 'aload 1)
    1412              (emit 'bipush (variable-index variable))
    1413              (emit 'aaload)
    1414              (emit-move-from-stack target))
    1415             (*child-p*
    1416              ;; The general case.
    1417              (emit 'aload *context-register*) ; Array of arrays.
    1418              (aver (fixnump (variable-level variable)))
    1419              (emit 'bipush (variable-level variable))
    1420              (emit 'aaload) ; Locals array for level in question.
    1421              (aver (variable-index variable))
    1422              (emit 'bipush (variable-index variable))
     1453            ((variable-index variable)
     1454             (aver (not (null (compiland-argument-register *current-compiland*))))
     1455             (emit 'aload (compiland-argument-register *current-compiland*))
     1456             (emit-push-constant-int (variable-index variable))
    14231457             (emit 'aaload)
    14241458             (emit-move-from-stack target))
    14251459            (t
    1426              (emit 'aload 1)
    1427              (aver (variable-index variable))
    1428              (emit 'bipush (variable-index variable))
    1429              (emit 'aaload)
    1430              (emit-move-from-stack target)))
     1460             (dformat t "VAR-REF unhandled case variable = ~S~%" (variable-name variable))
     1461             (aver (progn 'unhandled-case nil))))
    14311462           (when (eq representation :unboxed-fixnum)
    14321463             (dformat t "resolve-variables calling emit-unbox-fixnum~%")
     
    14341465        (207 ; VAR-SET
    14351466         (let ((variable (car (instruction-args instruction))))
     1467           (dformat t "var-set var = ~S reg = ~S closure index = ~S~%"
     1468                    (variable-name variable)
     1469                    (variable-register variable)
     1470                    (variable-closure-index variable)
     1471                    )
    14361472           (aver (variable-p variable))
    14371473           (aver (not (variable-special-p variable)))
    14381474           (cond ((variable-register variable)
    14391475                  (emit 'astore (variable-register variable)))
    1440                  ((= (variable-level variable) *nesting-level* 0)
    1441                   (emit 'aload 1) ; Stack: value array
     1476                 ((variable-closure-index variable)
     1477                  (dformat t "variable = ~S closure-index = ~S~%"
     1478                           (variable-name variable) (variable-closure-index variable))
     1479                  (aver (not (null (compiland-closure-register *current-compiland*))))
     1480                  (emit 'aload (compiland-closure-register *current-compiland*))
    14421481                  (emit 'swap) ; array value
    1443                   (emit 'bipush (variable-index variable)) ; array value index
    1444                   (emit 'swap) ; array index value
    1445                   (emit 'aastore))
    1446                  ((and (variable-index variable) ; A local at the current nesting level.
    1447                        (= (variable-level variable) *nesting-level*))
    1448                   (emit 'aload 1) ; Stack: value array
    1449                   (emit 'swap) ; array value
    1450                   (emit 'bipush (variable-index variable)) ; array value index
     1482                  (emit 'bipush (variable-closure-index variable))
    14511483                  (emit 'swap) ; array index value
    14521484                  (emit 'aastore)
    14531485                  )
    1454                  (*child-p*
    1455                   ;; The general case.
    1456                   (emit 'aload *context-register*) ; Array of arrays.
    1457                   (emit 'bipush (variable-level variable))
    1458                   (emit 'aaload) ; Locals array for level in question.
    1459                   (emit 'swap) ; array value
    1460                   (emit 'bipush (variable-index variable)) ; array value index
    1461                   (emit 'swap) ; array index value
    1462                   (emit 'aastore))
    14631486                 (t
    1464                   (emit 'aload 1) ; Stack: value array
     1487                  (dformat t "var-set fall-through case~%")
     1488                  (aver (not (null (compiland-argument-register *current-compiland*))))
     1489                  (emit 'aload (compiland-argument-register *current-compiland*)) ; Stack: value array
    14651490                  (emit 'swap) ; array value
    14661491                  (emit 'bipush (variable-index variable)) ; array value index
     
    17621787         (*code* ())
    17631788         (*handlers* nil))
     1789    (dformat t "make-constructor super = ~S~%" super)
    17641790    (setf (method-name-index constructor) (pool-name (method-name constructor)))
    17651791    (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor)))
    17661792    (setf (method-max-locals constructor) 1)
    1767     (cond (*child-p*
    1768            (emit 'aload_0) ;; this
    1769            (let* ((*print-level* nil)
    1770                   (*print-length* nil)
    1771                   (s (%format nil "~S" args)))
    1772              (emit 'ldc
    1773                    (pool-string s))
    1774              (emit-invokestatic +lisp-class+
    1775                                 "readObjectFromString"
    1776                                 "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
    1777                                 0))
    1778            (emit-invokespecial super
    1779                                "<init>"
    1780                                "(Lorg/armedbear/lisp/LispObject;)V"
    1781                                -2))
    1782           (*hairy-arglist-p*
    1783            (emit 'aload_0) ;; this
    1784            (emit 'aconst_null) ;; name
    1785            (let* ((*print-level* nil)
    1786                   (*print-length* nil)
    1787                   (s (%format nil "~S" args)))
    1788              (emit 'ldc
    1789                    (pool-string s))
    1790              (emit-invokestatic +lisp-class+
    1791                                 "readObjectFromString"
    1792                                 "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
    1793                                 0))
    1794            (emit-push-nil) ;; body
    1795            (emit 'aconst_null) ;; environment
    1796            (emit-invokespecial super
    1797                                "<init>"
    1798 ;;                                "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/Environment;)V"
    1799                                `((,+lisp-symbol+ ,+lisp-object+ ,+lisp-object+ ,+lisp-environment+) nil)
    1800                                -5))
    1801           (t
    1802            (emit 'aload_0)
    1803            (emit-invokespecial super
    1804                                "<init>"
    1805                                "()V"
    1806                                -1)))
     1793    (cond
     1794     (*hairy-arglist-p*
     1795      (emit 'aload_0) ;; this
     1796      (emit 'aconst_null) ;; name
     1797      (let* ((*print-level* nil)
     1798             (*print-length* nil)
     1799             (s (%format nil "~S" args)))
     1800        (emit 'ldc
     1801              (pool-string s))
     1802        (emit-invokestatic +lisp-class+
     1803                           "readObjectFromString"
     1804                           "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
     1805                           0))
     1806      (emit-push-nil) ;; body
     1807      (emit 'aconst_null) ;; environment
     1808      (emit-invokespecial super
     1809                          "<init>"
     1810                          ;;                                "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/Environment;)V"
     1811                          `((,+lisp-symbol+ ,+lisp-object+ ,+lisp-object+ ,+lisp-environment+) nil)
     1812                          -5))
     1813     (*child-p*
     1814      (cond
     1815       ((null *closure-variables*)
     1816        (emit 'aload_0)
     1817        (emit-invokespecial super
     1818                            "<init>"
     1819                            "()V"
     1820                            -1))
     1821        (t
     1822         (emit 'aload_0) ;; this
     1823         (let* ((*print-level* nil)
     1824                (*print-length* nil)
     1825                (s (%format nil "~S" args)))
     1826           (emit 'ldc
     1827                 (pool-string s))
     1828           (emit-invokestatic +lisp-class+
     1829                              "readObjectFromString"
     1830                              "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
     1831                              0))
     1832         (emit-invokespecial super
     1833                             "<init>"
     1834                             "(Lorg/armedbear/lisp/LispObject;)V"
     1835                             -2))))
     1836     (t
     1837      (emit 'aload_0)
     1838      (emit-invokespecial super
     1839                          "<init>"
     1840                          "()V"
     1841                          -1)))
    18071842    (setf *code* (append *static-code* *code*))
    18081843    (emit 'return)
     
    25512586           (QUOTE
    25522587            nil)
     2588           (LAMBDA
     2589            nil)
    25532590           ((RETURN-FROM GO CATCH THROW UNWIND-PROTECT BLOCK)
    25542591            t)
     
    27182755
    27192756(defun compile-local-function-call (form target)
     2757  (dformat t "compile-local-function-call~%")
    27202758  (let* ((op (car form))
    27212759         (args (cdr form))
    27222760         (local-function (find-local-function op)))
    2723     (cond ((local-function-variable local-function)
    2724            ;; LABELS
    2725            (emit 'var-ref (local-function-variable local-function) :stack))
    2726           (t
    2727            (let* ((g (if *compile-file-truename*
    2728                          (declare-local-function local-function)
    2729                          (declare-object (local-function-function local-function)))))
    2730              (emit 'getstatic
    2731                    *this-class*
    2732                    g
    2733                    +lisp-object+)))) ; Stack: template-function
    2734     (emit 'sipush (length args))
    2735     (emit 'anewarray "org/armedbear/lisp/LispObject")
    2736     (let ((i 0)
    2737           (must-clear-values nil))
    2738       (dolist (arg args)
    2739         (emit 'dup)
    2740         (emit 'sipush i)
    2741         (compile-form arg :target :stack)
    2742         (emit 'aastore) ; store value in array
    2743         (unless must-clear-values
    2744           (unless (single-valued-p arg)
    2745             (setf must-clear-values t)))
    2746         (incf i))
    2747       (when must-clear-values
    2748         (emit-clear-values))) ; array left on stack here
    2749     ;; Stack: template-function args
    27502761    (cond
    2751      ((zerop *nesting-level*)
    2752       (dformat t "compile-local-function-call zerop *nesting-level* case~%")
    2753       ;; Make a vector of size 1.
    2754       (emit 'sipush 1)
    2755       (emit 'anewarray "[Lorg/armedbear/lisp/LispObject;")
    2756       ;; Store args/locals register in slot 0.
    2757       (emit 'dup)
    2758       (emit 'sipush 0)
    2759       (emit 'aload 1) ;; Args/locals register.
    2760       (emit 'aastore))
    2761      ((= *nesting-level* (local-function-nesting-level local-function))
    2762       (emit 'aload 2))
     2762     ((local-function-variable local-function)
     2763      ;; LABELS
     2764      (dformat t "compile-local-function-call LABELS case~%")
     2765      (emit 'var-ref (local-function-variable local-function) :stack))
    27632766     (t
    2764       ;; This is the general case.
    2765       (dformat t "compile-local-function-call general case~%")
    2766       (emit 'sipush (local-function-nesting-level local-function))
    2767       (emit 'anewarray "[Lorg/armedbear/lisp/LispObject;")
    2768       (dotimes (i (1- (local-function-nesting-level local-function)))
    2769         (emit 'dup)
    2770         (emit 'sipush i)
    2771         (emit 'aload 2)
    2772         (emit 'sipush i)
    2773         (emit 'aaload)
    2774         (emit 'aastore))
    2775       (emit 'dup)
    2776       (emit 'sipush (1- (local-function-nesting-level local-function)))
    2777       (emit 'aload 1) ; Args/locals.
    2778       (emit 'aastore)))
    2779     ;; Stack: template-function args context
    2780     (emit-invokevirtual +lisp-object-class+
    2781                         "execute"
    2782                         "([Lorg/armedbear/lisp/LispObject;[[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
    2783                         -2)
     2767      (let* ((g (if *compile-file-truename*
     2768                    (declare-local-function local-function)
     2769                    (declare-object (local-function-function local-function)))))
     2770        (emit 'getstatic
     2771              *this-class*
     2772              g
     2773              +lisp-object+)))) ; Stack: template-function
     2774
     2775    (when *closure-variables*
     2776      (emit 'checkcast +lisp-ctf-class+))
     2777
     2778      (when *closure-variables*
     2779        ;; First arg is closure variable array.
     2780        (aver (not (null (compiland-closure-register *current-compiland*))))
     2781        (emit 'aload (compiland-closure-register *current-compiland*)))
     2782      (cond
     2783       ((> (length args) 4)
     2784        (emit-push-constant-int (length args))
     2785        (emit 'anewarray "org/armedbear/lisp/LispObject")
     2786        (let ((i 0)
     2787              (must-clear-values nil))
     2788          (dolist (arg args)
     2789            (emit 'dup)
     2790            (emit 'sipush i)
     2791            (compile-form arg :target :stack)
     2792            (emit 'aastore) ; store value in array
     2793            (unless must-clear-values
     2794              (unless (single-valued-p arg)
     2795                (setf must-clear-values t)))
     2796            (incf i))
     2797          (when must-clear-values
     2798            (emit-clear-values))) ; array left on stack here
     2799        )
     2800       (t
     2801        (let ((must-clear-values nil))
     2802          (dolist (arg args)
     2803            (compile-form arg :target :stack)
     2804            (unless must-clear-values
     2805              (unless (single-valued-p arg)
     2806                (setf must-clear-values t))))
     2807          (when must-clear-values
     2808            (emit-clear-values))) ; args left on stack here
     2809        ))
     2810
     2811    (if *closure-variables*
     2812          (case (length args)
     2813            (0
     2814             (emit-invokevirtual +lisp-ctf-class+
     2815                                 "execute"
     2816                                 "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
     2817                                 -1))
     2818            (1
     2819             (emit-invokevirtual +lisp-ctf-class+
     2820                                 "execute"
     2821                                 "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
     2822                                 -2))
     2823            (2
     2824             (emit-invokevirtual +lisp-ctf-class+
     2825                                 "execute"
     2826                                 "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
     2827                                 -3))
     2828            (3
     2829             (emit-invokevirtual +lisp-ctf-class+
     2830                                 "execute"
     2831                                 "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
     2832                                 -4))
     2833            (4
     2834             (emit-invokevirtual +lisp-ctf-class+
     2835                                 "execute"
     2836                                 "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
     2837                                 -5))
     2838            (t
     2839             (emit-invokevirtual +lisp-ctf-class+
     2840                                 "execute"
     2841                                 "([Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
     2842                                 -2)))
     2843          ;; No closure variables.
     2844          (case (length args)
     2845            (0
     2846             (emit-invokevirtual +lisp-object-class+
     2847                                 "execute"
     2848                                 "()Lorg/armedbear/lisp/LispObject;"
     2849                                 0))
     2850            (1
     2851             (emit-invokevirtual +lisp-object-class+
     2852                                 "execute"
     2853                                 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
     2854                                 -1))
     2855            (2
     2856             (emit-invokevirtual +lisp-object-class+
     2857                                 "execute"
     2858                                 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
     2859                                 -2))
     2860            (3
     2861             (emit-invokevirtual +lisp-object-class+
     2862                                 "execute"
     2863                                 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
     2864                                 -3))
     2865            (4
     2866             (emit-invokevirtual +lisp-object-class+
     2867                                 "execute"
     2868                                 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
     2869                                 -4))
     2870            (t
     2871             (emit-invokevirtual +lisp-object-class+
     2872                                 "execute"
     2873                                 "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
     2874                                 -1))))
    27842875    (cond ((null target)
    27852876           (emit 'pop)
     
    28162907
    28172908(defun compile-test-2 (form negatep)
    2818 ;;   (dformat t "compile-test-2 ~S~%" form)
    28192909  (let* ((op (car form))
    28202910         (args (cdr form))
     
    31813271                             "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V"
    31823272                             -3))
    3183         (*use-locals-vector*
    3184          (emit 'aload 1) ; Stack: value array
     3273        ((variable-closure-index variable)
     3274         (emit 'aload (compiland-closure-register *current-compiland*))
    31853275         (emit 'swap) ; array value
    3186          (emit 'bipush (variable-index variable)) ; array value index
     3276         (emit-push-constant-int (variable-closure-index variable))
    31873277         (emit 'swap) ; array index value
    31883278         (emit 'aastore))
     
    32043294               (setf bind-special-p t))
    32053295              (t
    3206                (setf (variable-index variable) (length (context-vars *context*)))
    3207                (unless *use-locals-vector*
     3296;;                (setf (variable-index variable) (length (context-vars *context*)))
     3297               (unless (variable-closure-index variable)
    32083298                 (setf (variable-register variable) (allocate-register)))
    3209                (add-variable-to-context variable)))))
     3299;;                (add-variable-to-context variable)
     3300               ))))
    32103301    ;; If we're going to bind any special variables...
    32113302    (when bind-special-p
     
    33073398       (p2-let-bindings block))
    33083399      (LET*
    3309        (compile-let*-bindings block)))
     3400       (p2-let*-bindings block)))
    33103401    ;; Body of LET/LET*.
    33113402    (compile-progn-body (cddr form) target)
     
    33193410  (dolist (variable (block-vars block))
    33203411    (unless (variable-special-p variable)
    3321       (setf (variable-index variable) (length (context-vars *context*)))
    3322       (unless *use-locals-vector*
    3323         (setf (variable-register variable) (allocate-register)))
    3324       (add-variable-to-context variable)))
     3412      (unless (variable-closure-index variable)
     3413        (setf (variable-register variable) (allocate-register)))))
    33253414  (let ((*register* *register*)
    33263415        (must-clear-values nil))
     
    33763465  ;; Now make the variables visible.
    33773466  (dolist (variable (block-vars block))
    3378     (push variable *visible-variables*)
    3379 ;;     (push variable *all-variables*)
    3380     ))
    3381 
    3382 (defun compile-let*-bindings (block)
     3467    (push variable *visible-variables*)))
     3468
     3469(defun p2-let*-bindings (block)
    33833470  (let ((must-clear-values nil))
    33843471    ;; Generate code to evaluate initforms and bind variables.
     
    33863473      (let* ((initform (variable-initform variable))
    33873474             (boundp nil))
    3388         (cond ((and (variable-special-p variable)
    3389                     (eq initform (variable-name variable)))
    3390                (emit-push-current-thread)
    3391                (emit 'getstatic
    3392                      *this-class*
    3393                      (declare-symbol (variable-name variable))
    3394                      +lisp-symbol+)
    3395                (emit-invokevirtual +lisp-thread-class+
    3396                                    "bindSpecialToCurrentValue"
    3397                                    "(Lorg/armedbear/lisp/Symbol;)V"
    3398                                    -2)
    3399                (setf boundp t))
    3400               (initform
    3401                (cond
    3402                 ((and *trust-user-type-declarations*
    3403                       (not *use-locals-vector*)
    3404                       (not (variable-special-p variable))
    3405                       (variable-declared-type variable)
    3406                       (subtypep (variable-declared-type variable) 'FIXNUM))
    3407                  (dformat t "compile-let*-bindings declared fixnum case~%")
    3408                  (setf (variable-representation variable) :unboxed-fixnum)
    3409                  (compile-form initform :target :stack :representation :unboxed-fixnum)
    3410                  (setf (variable-register variable) (allocate-register))
    3411                  (emit 'istore (variable-register variable))
    3412                  (setf boundp t))
    3413                 ((and (not *use-locals-vector*)
    3414                       (not (variable-special-p variable))
    3415                       (eql (variable-writes variable) 0)
    3416                       (subtypep (derive-type initform) 'FIXNUM))
    3417                  (dformat t "compile-let*-bindings read-only fixnum case: ~S~%"
    3418                           (variable-name variable))
    3419                  (setf (variable-representation variable) :unboxed-fixnum)
    3420                  (compile-form initform :target :stack :representation :unboxed-fixnum)
    3421                  (setf (variable-register variable) (allocate-register))
    3422                  (emit 'istore (variable-register variable))
    3423                  (setf boundp t))
    3424                 (t
    3425                  (compile-form initform :target :stack)))
    3426                (unless must-clear-values
    3427                  (unless (single-valued-p initform)
    3428                    (setf must-clear-values t))))
    3429               (t
    3430                (emit-push-nil)))
     3475        (cond
     3476         ((and (variable-special-p variable)
     3477               (eq initform (variable-name variable)))
     3478          (emit-push-current-thread)
     3479          (emit 'getstatic
     3480                *this-class*
     3481                (declare-symbol (variable-name variable))
     3482                +lisp-symbol+)
     3483          (emit-invokevirtual +lisp-thread-class+
     3484                              "bindSpecialToCurrentValue"
     3485                              "(Lorg/armedbear/lisp/Symbol;)V"
     3486                              -2)
     3487          (setf boundp t))
     3488         (initform
     3489          (cond
     3490           ((and *trust-user-type-declarations*
     3491;;                  (not *use-locals-vector*)
     3492                 (null (variable-closure-index variable))
     3493                 (not (variable-special-p variable))
     3494                 (variable-declared-type variable)
     3495                 (subtypep (variable-declared-type variable) 'FIXNUM))
     3496            (dformat t "p2-let*-bindings declared fixnum case~%")
     3497            (setf (variable-representation variable) :unboxed-fixnum)
     3498            (compile-form initform :target :stack :representation :unboxed-fixnum)
     3499            (setf (variable-register variable) (allocate-register))
     3500            (emit 'istore (variable-register variable))
     3501            (setf boundp t))
     3502           ((and ;;(not *use-locals-vector*)
     3503                 (null (variable-closure-index variable))
     3504                 (not (variable-special-p variable))
     3505                 (eql (variable-writes variable) 0)
     3506                 (subtypep (derive-type initform) 'FIXNUM))
     3507            (dformat t "p2-let*-bindings read-only fixnum case: ~S~%"
     3508                     (variable-name variable))
     3509            (setf (variable-representation variable) :unboxed-fixnum)
     3510            (compile-form initform :target :stack :representation :unboxed-fixnum)
     3511            (setf (variable-register variable) (allocate-register))
     3512            (emit 'istore (variable-register variable))
     3513            (setf boundp t))
     3514           (t
     3515            (compile-form initform :target :stack)))
     3516          (unless must-clear-values
     3517            (unless (single-valued-p initform)
     3518              (setf must-clear-values t))))
     3519         (t
     3520          (emit-push-nil)))
    34313521        (unless (variable-special-p variable)
    3432           (setf (variable-index variable) (length (context-vars *context*)))
    3433           (unless (or *use-locals-vector* (variable-register variable))
    3434             (setf (variable-register variable) (allocate-register)))
    3435           (add-variable-to-context variable))
     3522          (unless (or (variable-closure-index variable) (variable-register variable))
     3523            (setf (variable-register variable) (allocate-register))))
    34363524        (push variable *visible-variables*)
    3437 ;;         (push variable *all-variables*)
    34383525        (unless boundp
    34393526          (compile-binding variable))))
     
    34573544        (specials (process-special-declarations (cdr form))))
    34583545    (dolist (var specials)
    3459       (push-variable var t))
     3546      (push (make-variable :name var :special-p t) *visible-variables*))
    34603547    (cond ((null (cdr form))
    34613548           (when target
     
    35983685               (emit 'aload register)
    35993686               (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)))
     3687           (maybe-generate-interrupt-check) ;; FIXME not exactly right, but better than nothing
    36003688           (emit 'goto (tag-label tag)))
    36013689          (t
     
    38683956                 (when (and (consp arg)
    38693957                            (not (constantp (second arg))))
    3870                    (error "COMPILE-LOCAL-FUNCTION: can't handle optional argument with non-constant initform.")))))))
     3958                   (error "P2-LOCAL-FUNCTION: can't handle optional argument with non-constant initform.")))))))
    38713959    (setf form (compiland-lambda-expression compiland))
    38723960    (let ((*nesting-level* (1+ *nesting-level*)))
     
    39013989
    39023990(defun p2-flet (form &key (target *val*) representation)
    3903   (if *use-locals-vector*
    3904       (let ((*local-functions* *local-functions*)
    3905             (compilands (cadr form))
    3906             (body (cddr form)))
    3907         (dolist (compiland compilands)
    3908           (p2-local-function compiland nil))
    3909         (do ((forms body (cdr forms)))
    3910             ((null forms))
    3911           (compile-form (car forms) :target (if (cdr forms) nil target))))
    3912       (error "COMPILE-FLET: unsupported case.")))
     3991  (let ((*local-functions* *local-functions*)
     3992        (compilands (cadr form))
     3993        (body (cddr form)))
     3994    (dolist (compiland compilands)
     3995      (p2-local-function compiland nil))
     3996    (do ((forms body (cdr forms)))
     3997        ((null forms))
     3998      (compile-form (car forms) :target (if (cdr forms) nil target)))))
    39133999
    39144000(defun p2-labels (form &key target representation)
    3915   (if *use-locals-vector*
    3916       (let ((*local-functions* *local-functions*)
    3917 ;;             (definitions (cadr form))
    3918             (compilands (cadr form))
    3919             (body (cddr form)))
    3920 ;;         (dolist (definition definitions)
    3921 ;;           (let* ((name (car definition))
    3922 ;;                  (variable (push-variable (copy-symbol name) nil)))
    3923 ;;             (push (make-local-function :name name :variable variable)
    3924 ;;                   *local-functions*)))
    3925 ;;         (dolist (definition definitions)
    3926 ;;           (let* ((name (car definition))
    3927 ;;                  (local-function (find-local-function name)))
    3928 ;;             (compile-local-function definition local-function)))
    3929         (dolist (compiland compilands)
    3930           (aver (compiland-p compiland))
    3931           (let* ((name (compiland-name compiland))
    3932                  (variable (push-variable (copy-symbol name) nil)))
    3933             (push (make-local-function :name name :variable variable)
    3934                   *local-functions*)))
    3935         (dolist (compiland compilands)
    3936           (aver (compiland-p compiland))
    3937           (let* ((name (compiland-name compiland))
    3938                  (local-function (find-local-function name)))
    3939             (p2-local-function compiland local-function)))
    3940         (do ((forms body (cdr forms)))
    3941             ((null forms))
    3942           (compile-form (car forms) :target (if (cdr forms) nil target))))
    3943       (error "COMPILE-LABELS: unsupported case.")))
     4001  (let ((*local-functions* *local-functions*)
     4002        (local-functions (cadr form))
     4003        (body (cddr form)))
     4004    (dolist (local-function local-functions)
     4005      (push local-function *local-functions*)
     4006      (push (local-function-variable local-function) *visible-variables*))
     4007    (dolist (local-function local-functions)
     4008      (let ((variable (local-function-variable local-function)))
     4009        (aver (null (variable-register variable)))
     4010        (unless (variable-closure-index variable)
     4011          (setf (variable-register variable) (allocate-register)))
     4012        (setf (variable-index variable) nil)))
     4013    (dolist (local-function local-functions)
     4014      (p2-local-function (local-function-compiland local-function) local-function))
     4015    (do ((forms body (cdr forms)))
     4016        ((null forms))
     4017      (compile-form (car forms) :target (if (cdr forms) nil target)))))
    39444018
    39454019(defun contains-symbol (symbol form)
     
    39684042                (return t))))))))
    39694043
    3970 (defun compile-lambda (form target)
    3971   (let* (;;(closure-vars *visible-variables*)
    3972          (lambda-list (cadr form))
    3973          (lambda-body (cddr form)))
    3974     (unless *use-locals-vector*
    3975       (error "*USE-LOCALS-VECTOR* is NIL, can't compile lambda form~S"))
     4044(defun p2-lambda (compiland target)
     4045  (let* ((lambda-list (cadr (compiland-lambda-expression compiland))))
    39764046    (when (or (memq '&optional lambda-list)
    39774047              (memq '&key lambda-list))
     
    39834053                 (when (and (consp arg)
    39844054                            (not (constantp (second arg))))
    3985                    (error "COMPILE-LAMBDA: can't handle optional argument with non-constant initform.")))))))
     4055                   (error "P2-LAMBDA: can't handle optional argument with non-constant initform.")))))))
    39864056    (cond (*compile-file-truename*
    3987            (let ((classfile
    3988                   (let ((*nesting-level* (1+ *nesting-level*)))
    3989                     (compile-defun nil form nil (sys::next-classfile-name)))))
    3990              (let* ((local-function (make-local-function :classfile classfile))
    3991                     (g (declare-local-function local-function)))
    3992                (emit 'getstatic
    3993                      *this-class*
    3994                      g
    3995                      +lisp-object+))))
     4057
     4058           (setf (compiland-classfile compiland) (sys::next-classfile-name))
     4059
     4060           (let ((*current-compiland* compiland)
     4061                 (*speed* *speed*)
     4062                 (*safety* *safety*)
     4063                 (*debug* *debug*)
     4064                 compiled-function)
     4065             (p2-compiland compiland))
     4066
     4067           (let* ((local-function (make-local-function :classfile (compiland-classfile compiland)))
     4068                  (g (declare-local-function local-function)))
     4069             (emit 'getstatic
     4070                   *this-class*
     4071                   g
     4072                   +lisp-object+))
     4073
     4074;;              )
     4075           )
    39964076          (t
    3997            (let* ((classfile
    3998                    (prog1
     4077           (setf (compiland-classfile compiland)
     4078                 (prog1
    39994079                    (%format nil "local-~D.class" *child-count*)
    40004080                    (incf *child-count*)))
    4001                   (compiled-function (sys:load-compiled-function
    4002                                       (let ((*nesting-level* (1+ *nesting-level*)))
    4003                                         (compile-defun nil form nil classfile)))))
     4081           (let ((*current-compiland* compiland)
     4082                 (*speed* *speed*)
     4083                 (*safety* *safety*)
     4084                 (*debug* *debug*)
     4085                 compiled-function)
     4086             (p2-compiland compiland)
     4087             (setf compiled-function
     4088                   (sys:load-compiled-function (compiland-classfile compiland)))
    40044089             (emit 'getstatic
    40054090                   *this-class*
    40064091                   (declare-object compiled-function)
    40074092                   +lisp-object+))))
    4008     ;; Stack: template-function
    4009     (cond ((zerop *nesting-level*)
    4010            ;; Make a vector of size 1.
    4011            (emit 'sipush 1)
    4012            (emit 'anewarray "[Lorg/armedbear/lisp/LispObject;")
    4013            ;; Store args/locals register in slot 0.
    4014            (emit 'dup)
    4015            (emit 'sipush 0)
    4016            (emit 'aload 1) ;; Args/locals register.
    4017            (emit 'aastore))
    4018           (t
    4019 ;;            (emit 'aload 2)
    4020            (error "nesting level > 0, not supported")
    4021            ))
    4022     (emit-invokestatic +lisp-class+
    4023                        "makeCompiledClosure"
    4024                        "(Lorg/armedbear/lisp/LispObject;[[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
    4025                        -1) ; Stack: compiled-closure
     4093    (cond
     4094     ((null *closure-variables*)) ; Nothing to do.
     4095     ((compiland-closure-register *current-compiland*)
     4096      (emit 'aload (compiland-closure-register *current-compiland*))
     4097      (emit-invokestatic +lisp-class+
     4098                         "makeCompiledClosure"
     4099                         "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
     4100                         -1)
     4101      (emit 'checkcast "org/armedbear/lisp/CompiledClosure")
     4102      ) ; Stack: compiled-closure
     4103     (t
     4104      ;; Shouldn't happen.
     4105      (aver (progn 'unexpected nil))
     4106      (emit-push-constant-int 0)
     4107      (emit 'anewarray "org/armedbear/lisp/LispObject")))
    40264108    (emit-move-from-stack target)))
    40274109
    4028 (defun compile-function (form &key (target *val*) representation)
     4110(defun p2-function (form &key (target *val*) representation)
    40294111  (let ((name (second form))
    40304112        (local-function))
    4031     (cond ((symbolp name)
    4032            (cond ((setf local-function (find-local-function name))
    4033                   (if (local-function-variable local-function)
    4034                       (emit 'var-ref (local-function-variable local-function) :stack)
    4035                       (let ((g (if *compile-file-truename*
    4036                                    (declare-local-function local-function)
    4037                                    (declare-object (local-function-function local-function)))))
    4038                         (emit 'getstatic
    4039                               *this-class*
    4040                               g
    4041                               +lisp-object+))) ; Stack: template-function
    4042 ;;                   (emit 'aload *context-register*) ; Stack: template-function context
    4043                   (cond ((zerop *nesting-level*)
    4044                          ;; Make a vector of size 1.
    4045                          (emit 'sipush 1)
    4046                          (emit 'anewarray "[Lorg/armedbear/lisp/LispObject;")
    4047                          ;; Store args/locals register in slot 0.
    4048                          (emit 'dup)
    4049                          (emit 'sipush 0)
    4050                          (emit 'aload 1) ;; Args/locals register.
    4051                          (emit 'aastore))
    4052                         ((= *nesting-level* (local-function-nesting-level local-function))
    4053                          (emit 'aload 2))
    4054                         (t
    4055                          ;; This is the general case.
    4056                          (emit 'sipush (local-function-nesting-level local-function))
    4057                          (emit 'anewarray "[Lorg/armedbear/lisp/LispObject;")
    4058                          (dotimes (i (1- (local-function-nesting-level local-function)))
    4059                            (emit 'dup)
    4060                            (emit 'sipush i)
    4061                            (emit 'aload 2)
    4062                            (emit 'sipush i)
    4063                            (emit 'aaload)
    4064                            (emit 'aastore))
    4065                          (emit 'dup)
    4066                          (emit 'sipush (1- (local-function-nesting-level local-function)))
    4067                          (emit 'aload 1) ; Args/locals.
    4068                          (emit 'aastore)))
    4069 
    4070 
    4071                   (emit-invokestatic +lisp-class+
    4072                                      "makeCompiledClosure"
    4073                                      "(Lorg/armedbear/lisp/LispObject;[[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
    4074                                      -1) ; Stack: compiled-closure
    4075                   (emit-move-from-stack target))
    4076                  ((inline-ok name)
    4077                   (emit 'getstatic
    4078                         *this-class*
    4079                         (declare-function name)
    4080                         +lisp-object+)
    4081                   (emit-move-from-stack target))
    4082                  (t
    4083                   (emit 'getstatic
    4084                         *this-class*
    4085                         (declare-symbol name)
    4086                         +lisp-symbol+)
    4087                   (emit-invokevirtual +lisp-object-class+
    4088                                       "getSymbolFunctionOrDie"
    4089                                       "()Lorg/armedbear/lisp/LispObject;"
    4090                                       0)
    4091                   (emit-move-from-stack target))))
    4092           ((and (consp name) (eq (car name) 'SETF))
    4093            ; FIXME Need to check for NOTINLINE declaration!
    4094            (cond ((member name *toplevel-defuns* :test #'equal)
    4095                   (emit 'getstatic
    4096                         *this-class*
    4097                         (declare-setf-function name)
    4098                         +lisp-object+)
    4099                   (emit-move-from-stack target))
    4100                  ((and (null *compile-file-truename*)
    4101                        (fdefinition name))
    4102                   (emit 'getstatic
    4103                         *this-class*
    4104                         (declare-object (fdefinition name))
    4105                         +lisp-object+)
    4106                   (emit-move-from-stack target))
    4107                  (t
    4108                   (emit 'getstatic
    4109                         *this-class*
    4110                         (declare-symbol (cadr name))
    4111                         +lisp-symbol+)
    4112                   (emit-invokevirtual +lisp-symbol-class+
    4113                                       "getSymbolSetfFunctionOrDie"
    4114                                       "()Lorg/armedbear/lisp/LispObject;"
    4115                                       0)
    4116                   (emit-move-from-stack target))))
    4117           ((and (consp name) (eq (car name) 'LAMBDA))
    4118            (compile-lambda name target))
    4119           (t
    4120            (error "COMPILE-FUNCTION: unsupported case: ~S" form)))))
     4113    (cond
     4114     ((symbolp name)
     4115      (cond
     4116       ((setf local-function (find-local-function name))
     4117        (if (local-function-variable local-function)
     4118            (emit 'var-ref (local-function-variable local-function) :stack)
     4119            (let ((g (if *compile-file-truename*
     4120                         (declare-local-function local-function)
     4121                         (declare-object (local-function-function local-function)))))
     4122              (emit 'getstatic
     4123                    *this-class*
     4124                    g
     4125                    +lisp-object+))) ; Stack: template-function
     4126        (unless (zerop *nesting-level*)
     4127          (error "nesting level > 0, not supported"))
     4128        (cond
     4129         ((null *closure-variables*)) ; Nothing to do.
     4130         ((compiland-closure-register *current-compiland*)
     4131          (emit 'aload (compiland-closure-register *current-compiland*))
     4132          (emit-invokestatic +lisp-class+
     4133                             "makeCompiledClosure"
     4134                             "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
     4135                             -1)) ; Stack: compiled-closure
     4136         (t
     4137          (aver (progn 'unexpected nil))))
     4138        (emit-move-from-stack target))
     4139       ((inline-ok name)
     4140        (emit 'getstatic
     4141              *this-class*
     4142              (declare-function name)
     4143              +lisp-object+)
     4144        (emit-move-from-stack target))
     4145       (t
     4146        (emit 'getstatic
     4147              *this-class*
     4148              (declare-symbol name)
     4149              +lisp-symbol+)
     4150        (emit-invokevirtual +lisp-object-class+
     4151                            "getSymbolFunctionOrDie"
     4152                            "()Lorg/armedbear/lisp/LispObject;"
     4153                            0)
     4154        (emit-move-from-stack target))))
     4155     ((and (consp name) (eq (car name) 'SETF))
     4156      ; FIXME Need to check for NOTINLINE declaration!
     4157      (cond
     4158       ((member name *toplevel-defuns* :test #'equal)
     4159        (emit 'getstatic
     4160              *this-class*
     4161              (declare-setf-function name)
     4162              +lisp-object+)
     4163        (emit-move-from-stack target))
     4164       ((and (null *compile-file-truename*)
     4165             (fdefinition name))
     4166        (emit 'getstatic
     4167              *this-class*
     4168              (declare-object (fdefinition name))
     4169              +lisp-object+)
     4170        (emit-move-from-stack target))
     4171       (t
     4172        (emit 'getstatic
     4173              *this-class*
     4174              (declare-symbol (cadr name))
     4175              +lisp-symbol+)
     4176        (emit-invokevirtual +lisp-symbol-class+
     4177                            "getSymbolSetfFunctionOrDie"
     4178                            "()Lorg/armedbear/lisp/LispObject;"
     4179                            0)
     4180        (emit-move-from-stack target))))
     4181     ((compiland-p name)
     4182      (p2-lambda name target))
     4183     (t
     4184      (error "p2-function: unsupported case: ~S" form)))))
    41214185
    41224186(defun p2-ash (form &key (target *val*) representation)
     
    46484712
    46494713(defun compile-variable-reference (name target representation)
     4714  (dformat t "compile-variable-reference ~S~%" name)
    46504715  (let ((variable (find-visible-variable name)))
    46514716    (cond
     
    46854750;;       (dformat t "compile-variable-reference name = ~S representation = ~S~%"
    46864751;;                name representation)
     4752      (dformat t "compile-variable-reference ~S closure index = ~S~%"
     4753               name (variable-closure-index variable))
    46874754      (emit 'var-ref variable target representation)))))
    46884755
     
    47624829
    47634830(defun p2-the (form &key (target *val*) representation)
    4764   (dformat t "p2-the form = ~S~%" form)
    4765 ;;   (let ((type (second form))
    4766 ;;         (expr (third form)))
    4767 ;;   (cond
    4768 ;;    ((and (listp type) (eq (car type) 'VALUES))
    4769 ;;     ;; FIXME
    4770 ;;     (compile-form expr :target target :representation representation))
    4771 ;;    ((= *safety* 3)
    4772 ;;     (let* ((sym (gensym))
    4773 ;;            (new-expr
    4774 ;;             `(let ((,sym ,expr))
    4775 ;;                (sys::require-type ,sym ',type)
    4776 ;;                ,sym)))
    4777 ;; ;;       (dformat t "new-expr = ~S~%" new-expr)
    4778 ;;       (compile-form (p1 new-expr) :target target :representation representation)))
    4779 ;;    (t
    4780 ;;     (compile-form expr :target target :representation representation)))))
    47814831  (compile-form (third form) :target target :representation representation))
    47824832
     
    49735023                         (compile-function-call form target representation))))
    49745024                 ((and (consp op) (eq (car op) 'LAMBDA))
     5025                  (aver (progn 'unexpected-lambda nil))
    49755026                  (let ((new-form (list* 'FUNCALL form)))
    49765027                    (compile-form new-form
     
    50185069(defun analyze-args (args)
    50195070  (aver (not (memq '&AUX args)))
    5020   (when (or *use-locals-vector*
    5021             *child-p*
    5022             (memq '&KEY args)
     5071
     5072  (when *child-p*
     5073    (when (or (memq '&KEY args)
     5074              (memq '&OPTIONAL args)
     5075              (memq '&REST args))
     5076      (setf *using-arg-array* t)
     5077      (setf *hairy-arglist-p* t)
     5078      (return-from analyze-args
     5079                   (if *closure-variables*
     5080                       #.(%format nil "([~A[~A)~A" +lisp-object+ +lisp-object+ +lisp-object+)
     5081                       #.(%format nil "([~A)~A" +lisp-object+ +lisp-object+))))
     5082    (cond
     5083     (*closure-variables*
     5084      (return-from analyze-args
     5085                   (case (length args)
     5086                     (0 #.(%format nil "([~A)~A" +lisp-object+ +lisp-object+))
     5087                     (1 #.(%format nil "([~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+))
     5088                     (2 #.(%format nil "([~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+))
     5089                     (3 #.(%format nil "([~A~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+))
     5090                     (4 #.(%format nil "([~A~A~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+))
     5091                     (t
     5092                      (error "analyze-args unsupported case")))))
     5093     (t
     5094      (return-from analyze-args
     5095                   (case (length args)
     5096                     (0 #.(%format nil "()~A" +lisp-object+))
     5097                     (1 #.(%format nil "(~A)~A" +lisp-object+ +lisp-object+))
     5098                     (2 #.(%format nil "(~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+))
     5099                     (3 #.(%format nil "(~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+))
     5100                     (4 #.(%format nil "(~A~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+))
     5101                     (t (setf *using-arg-array* t)
     5102                        (setf *arity* (length args))
     5103                        #.(%format nil "([~A)~A" +lisp-object+ +lisp-object+)))))))
     5104
     5105
     5106  (when (or (memq '&KEY args)
    50235107            (memq '&OPTIONAL args)
    50245108            (memq '&REST args))
     
    50405124
    50415125(defun write-class-file (args body execute-method classfile)
     5126  (dformat t "write-class-file ~S~%" classfile)
    50425127  (let* ((super
    50435128          (cond (*child-p*
    5044                  "org/armedbear/lisp/ClosureTemplateFunction")
     5129                 (dformat t "write-class-file *child-p* case~%")
     5130                 (dformat t "*closure-variables* = ~S~%" (mapcar #'variable-name *closure-variables*))
     5131                 (dformat t "args = ~S~%" args)
     5132                 (dformat t "*hairy-arglist-p* = ~S~%" *hairy-arglist-p*)
     5133                 (if *closure-variables*
     5134                     "org/armedbear/lisp/ClosureTemplateFunction"
     5135                     (if *hairy-arglist-p*
     5136                         "org/armedbear/lisp/CompiledFunction"
     5137                         "org/armedbear/lisp/Primitive")))
    50455138                (*hairy-arglist-p*
    50465139                 "org/armedbear/lisp/CompiledFunction")
     
    50845177
    50855178(defun p1-compiland (compiland)
    5086   (let ((precompiled-form (compiland-lambda-expression compiland)))
    5087     (aver (eq (car precompiled-form) 'LAMBDA))
    5088     (process-optimization-declarations (cddr precompiled-form))
    5089     (let* ((lambda-list (cadr precompiled-form))
    5090            (closure (sys::make-closure `(lambda ,lambda-list nil) nil))
    5091            (syms (sys::varlist closure))
    5092            vars)
    5093       (dolist (sym syms)
    5094         (let ((var (make-variable :name sym)))
    5095           (push var vars)
    5096           (push var *all-variables*)))
    5097       (setf (compiland-arg-vars compiland) (nreverse vars)))
    5098     (let ((*visible-variables* *visible-variables*))
    5099       (dformat t "p1-compiland *visible-variables* = ~S~%"
    5100                (mapcar #'variable-name *visible-variables*))
    5101 ;;       (setf *visible-variables*
    5102 ;;             (append *visible-variables* (compiland-arg-vars compiland)))
    5103       (dolist (var (compiland-arg-vars compiland))
    5104         (push var *visible-variables*))
    5105 
    5106       (dformat t "p1-compiland *visible-variables* ==> ~S~%"
    5107                (mapcar #'variable-name *visible-variables*))
    5108       (setf (compiland-p1-result compiland) (p1 precompiled-form)))))
     5179  (let ((form (compiland-lambda-expression compiland)))
     5180;;     (dformat t "p1-compiland form = ~S~%" form)
     5181    (aver (eq (car form) 'LAMBDA))
     5182    (process-optimization-declarations (cddr form))
     5183
     5184    (let* ((lambda-list (cadr form))
     5185           (body (cddr form))
     5186           (auxvars (memq '&AUX lambda-list)))
     5187      (when auxvars
     5188        (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
     5189        (setf body (list (append (list 'LET* (cdr auxvars)) body))))
     5190
     5191
     5192      (let* ((closure (sys::make-closure `(lambda ,lambda-list nil) nil))
     5193             (syms (sys::varlist closure))
     5194             vars)
     5195        (dolist (sym syms)
     5196          (let ((var (make-variable :name sym)))
     5197            (push var vars)
     5198            (push var *all-variables*)))
     5199        (setf (compiland-arg-vars compiland) (nreverse vars))
     5200        (let ((*visible-variables* *visible-variables*))
     5201          (dformat t "p1-compiland *visible-variables* = ~S~%"
     5202                   (mapcar #'variable-name *visible-variables*))
     5203          (dolist (var (compiland-arg-vars compiland))
     5204            (push var *visible-variables*))
     5205
     5206          (dformat t "p1-compiland *visible-variables* ==> ~S~%"
     5207                   (mapcar #'variable-name *visible-variables*))
     5208          (setf (compiland-p1-result compiland)
     5209                ;;               (list* 'LAMBDA lambda-list (mapcar #'p1 (cddr form)))
     5210                (list* 'LAMBDA lambda-list (mapcar #'p1 body))
     5211                ;;             (p1 form)
     5212                ))))))
    51095213
    51105214(defun p2-compiland (compiland)
     
    51335237         (*child-p* (not (null (compiland-parent compiland))))
    51345238
    5135          (*use-locals-vector* (or (> (compiland-children *current-compiland*) 0)
    5136                                   (compiland-contains-lambda *current-compiland*)))
    5137 
    51385239         (descriptor (analyze-args args))
    51395240         (execute-method (make-method :name "execute"
     
    51465247         (*handlers* ())
    51475248
    5148          (*context* *context*)
    5149 
    5150          (*context-register* *context-register*)
     5249;;          (*context* *context*)
    51515250
    51525251         (*visible-variables* *visible-variables*)
     
    51725271
    51735272    (dformat t "pass2 *using-arg-array* = ~S~%" *using-arg-array*)
    5174     (dformat t "pass2 *use-locals-vector* = ~S~%" *use-locals-vector*)
    51755273    (dformat t "pass2 *child-p* = ~S~%" *child-p*)
    51765274    (dformat t "pass2 *nesting-level* = ~S~%" *nesting-level*)
    5177     (when (zerop *nesting-level*)
    5178       (setf *child-count* 0))
    5179     (setf *context* (make-context))
     5275;;     (when (zerop *nesting-level*)
     5276;;       (setf *child-count* 0))
     5277;;     (setf *context* (make-context))
    51805278    (setf (method-name-index execute-method)
    51815279          (pool-name (method-name execute-method)))
     
    51865284                  (vars (sys::varlist closure))
    51875285                  (index 0))
     5286             (dformat t "*hairy-arglist-p* = t vars = ~S~%" vars)
    51885287             (dolist (var vars)
    51895288               (let ((variable (find-visible-variable var)))
     
    51945293                 (aver (null (variable-index variable)))
    51955294                 (setf (variable-index variable) index)
    5196 
    5197 ;;                  (push variable *all-variables*)
    51985295                 (push variable parameters)
    5199                  (add-variable-to-context variable)
     5296;;                  (add-variable-to-context variable)
    52005297                 (incf index)))))
    52015298          (t
    5202            (let ((register 1)
     5299           (dformat t "*hairy-arglist-p* = nil~%")
     5300           (let ((register (if (and *closure-variables* *child-p*)
     5301                               2 ; Reg 1 is reserved for closure variables array.
     5302                               1))
    52035303                 (index 0))
    52045304             (dolist (arg args)
    5205                (aver (= index (length (context-vars *context*))))
     5305;;                (aver (= index (length (context-vars *context*))))
    52065306               (let ((variable (find-visible-variable arg)))
    52075307                 (when (null variable)
     
    52125312                 (aver (null (variable-index variable)))
    52135313                 (setf (variable-index variable) index)
    5214 
    5215 ;;                  (push variable *all-variables*)
    52165314                 (push variable parameters)
    5217                  (add-variable-to-context variable)
     5315;;                  (add-variable-to-context variable)
    52185316                 (incf register)
    52195317                 (incf index))))))
     
    52255323                 (setf variable (make-variable :name name
    52265324                                               :special-p t))
    5227 ;;                  (push variable *all-variables*)
    52285325                 (push variable *visible-variables*))
    52295326                (t
     
    52475344                       (when (and (variable-register variable)
    52485345                                  (not (variable-special-p variable))
     5346                                  (not (variable-used-non-locally-p variable))
    52495347                                  (subtypep (variable-declared-type variable) 'FIXNUM))
    52505348                         (setf (variable-representation variable) :unboxed-fixnum))))))))))))
     
    52545352                    )
    52555353
    5256     (allocate-register) ;; "this" pointer
     5354    (allocate-register) ;; register 0: "this" pointer
     5355    (when (and *closure-variables* *child-p*)
     5356      (setf (compiland-closure-register compiland) (allocate-register)) ;; register 1
     5357      (dformat t "closure register = ~S~%" (compiland-closure-register compiland)))
    52575358    (if *using-arg-array*
    52585359        ;; One slot for arg array.
    5259         (allocate-register)
     5360        (setf (compiland-argument-register compiland) (allocate-register))
    52605361        ;; Otherwise, one register for each argument.
    52615362        (dolist (arg args)
    52625363          (allocate-register)))
    5263     (cond (*child-p*
    5264            (setf *context-register* (allocate-register))
    5265            (aver (eql *context-register* 2)))
    5266           (*use-locals-vector*
    5267            (aver *using-arg-array*)
    5268            (setf *context-register* 1)))
     5364    (when (and *closure-variables* (not *child-p*))
     5365       (setf (compiland-closure-register compiland) (allocate-register))
     5366       (dformat t "closure register = ~S~%" (compiland-closure-register compiland)))
    52695367    ;; Reserve the next available slot for the value register.
    52705368    (setf *val* (allocate-register))
    52715369    ;; Reserve the next available slot for the thread register.
    52725370    (setf *thread* (allocate-register))
     5371
     5372    ;; Move args from their original registers to the closure variables array,
     5373    ;; if applicable.
     5374    (when *closure-variables*
     5375      (dformat t "moving arguments to closure array (if applicable)~%")
     5376      (cond
     5377       (*child-p*
     5378        (aver (eql (compiland-closure-register compiland) 1))
     5379        (emit 'aload (compiland-closure-register compiland))
     5380        )
     5381       (t
     5382        (emit-push-constant-int (length *closure-variables*))
     5383        (dformat t "p2-compiland ~S anewarray 1~%" (compiland-name compiland))
     5384        (emit 'anewarray "org/armedbear/lisp/LispObject")))
     5385      (dolist (variable parameters)
     5386        (dformat t "considering ~S ...~%" (variable-name variable))
     5387        (when (variable-closure-index variable)
     5388          (dformat t "moving variable ~S~%" (variable-name variable))
     5389          (cond
     5390           ((variable-register variable)
     5391;;             (aver (variable-register variable)) ;; FIXME need to handle the arg-array case too!
     5392            (when (eql (variable-register variable) (compiland-closure-register compiland))
     5393              (error "ERROR! compiland closure register = ~S var ~S register = ~S~%"
     5394                     (compiland-closure-register compiland)
     5395                     (variable-name variable)
     5396                     (variable-register variable)))
     5397            (emit 'dup) ; array
     5398            (emit-push-constant-int (variable-closure-index variable))
     5399            (emit 'aload (variable-register variable))
     5400            (emit 'aastore)
     5401            (setf (variable-register variable) nil) ; The variable has moved.
     5402            )
     5403           ((variable-index variable)
     5404;;             (aver (null (compiland-parent compiland))) ;; FIXME
     5405            (emit 'dup) ; array
     5406            (emit-push-constant-int (variable-closure-index variable))
     5407            (emit 'aload (compiland-argument-register compiland))
     5408            (emit-push-constant-int (variable-index variable))
     5409            (emit 'aaload)
     5410            (emit 'aastore)
     5411            (setf (variable-index variable) nil) ; The variable has moved.
     5412            )
     5413          )))
     5414      (aver (not (null (compiland-closure-register compiland))))
     5415      (cond
     5416       (*child-p*
     5417        (emit 'pop))
     5418       (t
     5419        (emit 'astore (compiland-closure-register compiland)))))
    52735420
    52745421    ;; Establish dynamic bindings for any variables declared special.
     
    53175464      (maybe-generate-interrupt-check)
    53185465      (cond
    5319        ((or *hairy-arglist-p* *use-locals-vector*)
     5466       (*child-p*
     5467        (dformat t "prologue experimental case (child)~%")
     5468        (when *hairy-arglist-p*
     5469          (dformat t "prologue case 1~%")
     5470          (emit 'aload_0) ; this
     5471          (aver (not (null (compiland-argument-register compiland))))
     5472          (emit 'aload (compiland-argument-register compiland)) ; arg vector
     5473          ; Reserve extra slots for locals if applicable.
     5474;;           (let ((extra (if *use-locals-vector*
     5475;;                            (length (context-vars *context*))
     5476;;                            0)))
     5477;;             (emit 'sipush extra))
     5478          (emit-push-constant-int 0)
     5479          (emit-invokevirtual *this-class*
     5480                              (if (or (memq '&optional args) (memq '&key args))
     5481                                  "processArgs"
     5482                                  "fastProcessArgs")
     5483                              "([Lorg/armedbear/lisp/LispObject;I)[Lorg/armedbear/lisp/LispObject;"
     5484                              -1)
     5485         (emit 'astore (compiland-argument-register compiland)))
     5486        )
     5487       (*hairy-arglist-p*
    53205488        (dformat t "prologue case 1~%")
    53215489        (emit 'aload_0) ; this
    5322         (emit 'aload_1) ; arg vector
     5490        (aver (not (null (compiland-argument-register compiland))))
     5491        (emit 'aload (compiland-argument-register compiland)) ; arg vector
    53235492        ; Reserve extra slots for locals if applicable.
    5324         (let ((extra (if *use-locals-vector*
    5325                          (length (context-vars *context*))
    5326                          0)))
    5327           (emit 'sipush extra))
     5493;;         (let ((extra (if *use-locals-vector*
     5494;;                          (length (context-vars *context*))
     5495;;                          0)))
     5496;;           (emit 'sipush extra))
     5497        (emit-push-constant-int 0)
    53285498        (emit-invokevirtual *this-class*
    53295499                            (if (or (memq '&optional args) (memq '&key args))
     
    53325502                            "([Lorg/armedbear/lisp/LispObject;I)[Lorg/armedbear/lisp/LispObject;"
    53335503                            -2)
    5334         (emit 'astore_1))
     5504        (emit 'astore (compiland-argument-register compiland)))
    53355505       ((not *using-arg-array*)
    53365506        (dformat t "prologue case 2~%")
     
    53605530    (setf (method-handlers execute-method) (nreverse *handlers*))
    53615531    (write-class-file args body execute-method classfile)
     5532    (dformat t "leaving p2-compiland ~S~%" (compiland-name compiland))
    53625533    classfile))
    53635534
     
    53725543    (p1-compiland compiland)
    53735544    (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*))
     5545    (setf *closure-variables*
     5546          (remove-if-not #'variable-used-non-locally-p *all-variables*))
     5547    (setf *closure-variables*
     5548          (remove-if #'variable-special-p *closure-variables*))
     5549    (dformat t "*closure-variables* = ~S~%" (mapcar #'variable-name *closure-variables*))
     5550
     5551    (when *closure-variables*
     5552      (let ((i 0))
     5553        (dolist (var (reverse *closure-variables*))
     5554          (setf (variable-closure-index var) i)
     5555          (dformat t "var = ~S closure index = ~S~%" (variable-name var)
     5556                   (variable-closure-index var))
     5557          (incf i))))
     5558
    53745559    ;; Pass 2.
    53755560    (prog1
     
    53845569  (unless (or (null environment) (sys::empty-environment-p environment))
    53855570    (error "COMPILE-DEFUN: unable to compile LAMBDA form defined in non-null lexical environment."))
     5571  (setf *child-count* 0)
    53865572  (handler-bind ((warning #'handle-warning))
    53875573    (let ((precompiled-form (if *current-compiland*
     
    55275713                             declare
    55285714                             funcall
    5529                              function
    55305715                             go
    55315716                             if
     
    55575742(install-p2-handler 'eql    'p2-eql)
    55585743(install-p2-handler 'flet   'p2-flet)
     5744(install-p2-handler 'function   'p2-function)
    55595745(install-p2-handler 'labels 'p2-labels)
    55605746(install-p2-handler 'logand 'p2-logand)
Note: See TracChangeset for help on using the changeset viewer.