source: trunk/j/src/org/armedbear/lisp/jvm.lisp @ 8367

Last change on this file since 8367 was 8367, checked in by piso, 17 years ago

Work in progress (tested).

File size: 219.6 KB
Line 
1;;; jvm.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: jvm.lisp,v 1.354 2005-01-17 04:50:38 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20(in-package "EXT")
21
22(export 'defsubst)
23
24(in-package "JVM")
25
26(export '(compile-defun *catch-errors* jvm-compile jvm-compile-package))
27
28(import '(sys::%format
29          sys::source-transform
30          sys::define-source-transform
31          sys::expand-source-transform))
32
33(require :source-transform)
34
35(require '#:opcodes)
36
37(shadow '(method variable))
38
39(defparameter *trust-user-type-declarations* t)
40
41(defvar *closure-variables* nil)
42
43(defvar *enable-dformat* nil)
44
45(defun dformat (destination control-string &rest args)
46  (when *enable-dformat*
47    (apply #'sys::%format destination control-string args)))
48
49(defun inline-expansion (name)
50  (let ((info (sys::function-info name)))
51    (and info (getf info :inline-expansion))))
52
53(defun (setf inline-expansion) (expansion name)
54  (let ((info (sys::function-info name)))
55    (setf info (sys::%putf info :inline-expansion expansion))
56    (setf (sys::function-info name) info))
57  expansion)
58
59;; Just an experiment...
60(defmacro defsubst (name lambda-list &rest body)
61  `(progn
62     (sys::%defun ',name ',lambda-list ',body)
63     (precompile ',name)
64     (setf (inline-expansion ',name)
65           (precompile-form (list* 'LAMBDA ',lambda-list ',body) t))
66     ',name))
67#+nil
68(defmacro defsubst (&rest args)
69  `(defun ,@args))
70
71;; (defvar *use-locals-vector* nil)
72
73(defvar *compiler-debug* nil)
74
75(defstruct compiland
76  name
77  lambda-expression
78  arg-vars
79  p1-result
80  classfile
81  parent
82  (children 0) ; Number of local functions defined with FLET or LABELS.
83  contains-lambda
84  argument-register
85  closure-register
86  )
87
88(defvar *current-compiland* nil)
89
90(defvar *pool* nil)
91(defvar *pool-count* 1)
92(defvar *pool-entries* nil)
93
94;; (defvar *stream* nil)
95(defvar *this-class* nil)
96
97(defvar *code* ())
98(defvar *static-code* ())
99(defvar *fields* ())
100
101;; All tags visible at the current point of compilation, some of which may not
102;; be in the current compiland.
103(defvar *visible-tags* ())
104
105;; Next available register.
106(defvar *register* 0)
107
108;; Total number of registers allocated.
109(defvar *registers-allocated* 0)
110
111(defvar *handlers* ())
112
113(defstruct handler
114  from
115  to
116  code
117  catch-type)
118
119;; Variables visible at the current point of compilation.
120(defvar *visible-variables* ())
121
122;; All variables seen so far.
123(defvar *all-variables* ())
124
125;; Undefined variables that we've already warned about.
126(defvar *undefined-variables* ())
127
128(defvar *dump-variables* nil)
129
130(defun dump-1-variable (variable)
131  (%format t "  ~S special-p = ~S register = ~S level = ~S index = ~S declared-type = ~S~%"
132           (variable-name variable)
133           (variable-special-p variable)
134           (variable-register variable)
135           (variable-level variable)
136           (variable-index variable)
137           (variable-declared-type variable)))
138
139(defun dump-variables (list caption &optional (force nil))
140  (when (or force *dump-variables*)
141    (write-string caption)
142    (if list
143        (dolist (variable list)
144          (dump-1-variable variable))
145        (%format t "  None.~%"))))
146
147(defstruct variable
148  name
149  initform
150  temp-register
151  special-p
152  (declared-type t)
153  representation ; NIL (i.e. a LispObject reference) or :UNBOXED-FIXNUM
154  register ; register number or NIL
155  index
156  closure-index
157  (reads 0)
158  (writes 0)
159  used-non-locally-p
160  (compiland *current-compiland*))
161
162;; obj can be a symbol or variable
163;; returns variable or nil
164(defun unboxed-fixnum-variable (obj)
165  (cond
166   ((symbolp obj)
167    (let ((variable (find-visible-variable obj)))
168      (if (and variable
169               (eq (variable-representation variable) :unboxed-fixnum))
170          variable
171          nil)))
172   ((variable-p obj)
173    (if (eq (variable-representation obj) :unboxed-fixnum)
174        obj
175        nil))
176   (t
177    nil)))
178
179(defun arg-is-fixnum-p (arg)
180  (or (fixnump arg)
181      (unboxed-fixnum-variable arg)))
182
183;; True for local functions defined with FLET or LABELS.
184(defvar *child-p* nil)
185
186(defvar *child-count* 0)
187
188(defun find-visible-variable (name)
189  (dolist (variable *visible-variables*)
190    (when (eq name (variable-name variable))
191      (return variable))))
192
193(defun unboxed-fixnum-variable-p (obj)
194;;   (let ((variable (and (symbolp obj)
195;;                        (find-visible-variable obj))))
196;;     (and variable
197;;          (eq (variable-representation variable) :unboxed-fixnum))))
198  (unboxed-fixnum-variable obj))
199
200(defun allocate-register ()
201  (let* ((register *register*)
202         (next-register (1+ register)))
203    (declare (type fixnum register next-register))
204    (setf *register* next-register)
205    (when (< *registers-allocated* next-register)
206      (setf *registers-allocated* next-register))
207    register))
208
209(defstruct local-function
210  name
211  compiland
212  function
213  classfile
214  variable)
215
216(defvar *local-functions* ())
217
218(defun find-local-function (name)
219  (find name *local-functions* :key #'local-function-name))
220
221(defvar *using-arg-array* nil)
222(defvar *hairy-arglist-p* nil)
223(defvar *arity* nil)
224
225(defvar *val* nil) ; index of value register
226
227(defstruct node
228  ;; Block name or (TAGBODY) or (LET) or (MULTIPLE-VALUE-BIND).
229  name
230  form
231  (compiland *current-compiland*))
232
233;; Used to wrap TAGBODYs, UNWIND-PROTECTs and LET/LET*/M-V-B forms as well as
234;; BLOCKs per se.
235(defstruct (block-node (:conc-name block-) (:include node))
236  (exit (gensym))
237  target
238  catch-tag
239  ;; True if there is any RETURN from this block.
240  return-p
241  ;; True if there is a non-local RETURN from this block.
242  non-local-return-p
243  ;; True if a tag in this tagbody is the target of a non-local GO.
244  non-local-go-p
245  ;; If non-nil, register containing saved dynamic environment for this block.
246  environment-register
247  ;; Only used in LET/LET*/M-V-B nodes.
248  vars
249  free-specials
250  )
251
252(defvar *blocks* ())
253
254(defun find-block (name)
255  (dolist (block *blocks*)
256    (when (eq name (block-name block))
257      (return block))))
258
259(defstruct tag
260  name
261  label
262  block
263  (compiland *current-compiland*))
264
265;;; Pass 1.
266
267(defun p1-let-vars (varlist)
268  (let ((vars ()))
269    (dolist (varspec varlist)
270      (cond ((consp varspec)
271             (let ((name (car varspec))
272                   (initform (p1 (cadr varspec))))
273               (push (make-variable :name name :initform initform) vars)))
274            (t
275             (push (make-variable :name varspec) vars))))
276    (setf vars (nreverse vars))
277    (dolist (variable vars)
278      (push variable *visible-variables*)
279      (push variable *all-variables*))
280    vars))
281
282(defun p1-let*-vars (varlist)
283  (let ((vars ()))
284    (dolist (varspec varlist)
285      (cond ((consp varspec)
286             (let* ((name (car varspec))
287                    (initform (p1 (cadr varspec)))
288                    (var (make-variable :name name :initform initform)))
289               (push var vars)
290               (push var *visible-variables*)
291               (push var *all-variables*)))
292            (t
293             (let ((var (make-variable :name varspec)))
294               (push var vars)
295               (push var *visible-variables*)
296               (push var *all-variables*)))))
297    (nreverse vars)))
298
299(defun p1-let/let* (form)
300  (let* ((*visible-variables* *visible-variables*)
301         (block (make-block-node :name '(LET)))
302         (*blocks* (cons block *blocks*))
303         (op (car form))
304         (varlist (cadr form))
305         (body (cddr form)))
306    (aver (or (eq op 'LET) (eq op 'LET*)))
307    (when (eq op 'LET)
308      ;; Convert to LET* if possible.
309      (dolist (varspec varlist (setf op 'LET*))
310        (or (atom varspec)
311            (constantp (cadr varspec))
312            (eq (car varspec) (cadr varspec))
313            (return nil))))
314    (let ((vars (if (eq op 'LET) (p1-let-vars varlist) (p1-let*-vars varlist)))
315          (free-specials '()))
316      (dformat t "p1-let/let* vars = ~S~%" (mapcar #'variable-name vars))
317      ;; Check for globally declared specials.
318      (dolist (variable vars)
319        (when (special-variable-p (variable-name variable))
320          (setf (variable-special-p variable) t)))
321      ;; Process declarations.
322      (dolist (subform body)
323        (unless (and (consp subform) (eq (car subform) 'DECLARE))
324          (return))
325        (let ((decls (cdr subform)))
326          (dolist (decl decls)
327            (case (car decl)
328              (SPECIAL
329               (dolist (sym (cdr decl))
330;;                  (dolist (variable vars)
331;;                    (when (eq sym (variable-name variable))
332;;                      (setf (variable-special-p variable) t)))
333                 (let ((variable (find sym vars :key #'variable-name)))
334                   (cond (variable
335                          (setf (variable-special-p variable) t))
336                         (t
337                          (dformat t "adding free special ~S~%" sym)
338                          (push (make-variable :name sym :special-p t) free-specials))))
339                 ))
340              (TYPE
341               (dolist (sym (cddr decl))
342                 (dolist (variable vars)
343                   (when (eq sym (variable-name variable))
344                     (setf (variable-declared-type variable) (cadr decl))))))))))
345      (setf (block-vars block) vars)
346      (setf (block-free-specials block) free-specials))
347    (setf body (mapcar #'p1 body))
348    (setf (block-form block) (list* op varlist body))
349    block))
350
351(defun p1-m-v-b (form)
352;;   (dformat t "p1-multiple-value-bind~%")
353  (let* ((*visible-variables* *visible-variables*)
354         (block (make-block-node :name '(MULTIPLE-VALUE-BIND)))
355         (*blocks* (cons block *blocks*))
356         (varlist (cadr form))
357         (values-form (caddr form))
358         (body (cdddr form)))
359    ;; Process the values-form first. ("The scopes of the name binding and
360    ;; declarations do not include the values-form.")
361    (setf values-form (p1 values-form))
362    (let ((vars ()))
363      (dolist (symbol varlist)
364        (let ((var (make-variable :name symbol)))
365          (push var vars)
366          (push var *visible-variables*)
367          (push var *all-variables*)))
368      ;; Check for globally declared specials.
369      (dolist (variable vars)
370        (when (special-variable-p (variable-name variable))
371          (setf (variable-special-p variable) t)))
372      ;; Process declarations.
373      (dolist (subform body)
374        (unless (and (consp subform) (eq (car subform) 'DECLARE))
375          (return))
376        (let ((decls (cdr subform)))
377          (dolist (decl decls)
378            (case (car decl)
379              (SPECIAL
380               (dolist (sym (cdr decl))
381                 (dolist (variable vars)
382                   (when (eq sym (variable-name variable))
383                     (setf (variable-special-p variable) t)))))
384              (TYPE
385               (dolist (sym (cddr decl))
386                 (dolist (variable vars)
387                   (when (eq sym (variable-name variable))
388                     (setf (variable-declared-type variable) (cadr decl))))))))))
389      (setf (block-vars block) (nreverse vars)))
390    (setf body (mapcar #'p1 body))
391    (setf (block-form block) (list* 'MULTIPLE-VALUE-BIND varlist values-form body))
392    block))
393
394(defun p1-block (form)
395  (let* ((block (make-block-node :name (cadr form)))
396         (*blocks* (cons block *blocks*)))
397    (setf (block-form block) (list* 'BLOCK (cadr form) (mapcar #'p1 (cddr form))))
398    block))
399
400(defun p1-return-from (form)
401  (let* ((name (second form))
402         (result-form (third form))
403         (block (find-block name)))
404    (cond ((null block)
405           (error "P1-RETURN-FROM: no block named ~S is currently visible." name))
406          ((eq (block-compiland block) *current-compiland*)
407           (setf (block-return-p block) t))
408          (t
409           (setf (block-return-p block) t)
410           (setf (block-non-local-return-p block) t))))
411  (list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form))))
412
413(defun p1-tagbody (form)
414  (let* ((block (make-block-node :name '(TAGBODY)))
415         (*blocks* (cons block *blocks*))
416         (*visible-tags* *visible-tags*)
417         (body (cdr form)))
418    ;; Make all the tags visible before processing the body forms.
419    (dolist (subform body)
420      (when (or (symbolp subform) (integerp subform))
421        (let* ((tag (make-tag :name subform :label (gensym) :block block)))
422          (push tag *visible-tags*))))
423    (let ((new-body '()))
424      (dolist (subform body)
425        (push (if (or (symbolp subform) (integerp subform))
426                  subform
427                  (p1 subform))
428              new-body))
429      (setf (block-form block) (list* 'TAGBODY (nreverse new-body))))
430    block))
431
432(defun p1-go (form)
433  (let* ((name (cadr form))
434         (tag (find-tag name)))
435    (unless tag
436      (error "p1-go: tag not found: ~S" name))
437    (unless (eq (tag-compiland tag) *current-compiland*)
438      (setf (block-non-local-go-p (tag-block tag)) t)))
439  form)
440
441(defun p1-flet (form)
442;;   (when *current-compiland*
443    (incf (compiland-children *current-compiland*) (length (cadr form)))
444;;     )
445  (let ((*current-compiland* *current-compiland*)
446        (compilands ()))
447    (dolist (definition (cadr form))
448      (let* ((name (car definition))
449             (lambda-list (cadr definition))
450             (body (cddr definition))
451             (compiland (make-compiland :name name
452                                        :parent *current-compiland*)))
453        (multiple-value-bind (body decls)
454            (sys::parse-body body)
455          (setf (compiland-lambda-expression compiland)
456                `(lambda ,lambda-list ,@decls (block ,name ,@body)))
457          (let ((*visible-variables* *visible-variables*)
458                (*current-compiland* compiland))
459            (p1-compiland compiland)))
460        (push compiland compilands)))
461  (list* (car form) (nreverse compilands) (mapcar #'p1 (cddr form)))))
462
463(defun p1-labels (form)
464  (incf (compiland-children *current-compiland*) (length (cadr form)))
465  (let ((*visible-variables* *visible-variables*)
466        (*local-functions* *local-functions*)
467        (*current-compiland* *current-compiland*)
468        (local-functions ()))
469    (dolist (definition (cadr form))
470      (let* ((name (car definition))
471             (lambda-list (cadr definition))
472             (body (cddr definition))
473             (compiland (make-compiland :name name
474                                        :parent *current-compiland*))
475             (variable (make-variable :name (copy-symbol name)))
476             (local-function (make-local-function :name name
477                                                  :compiland compiland
478                                                  :variable variable)))
479        (multiple-value-bind (body decls)
480          (sys::parse-body body)
481          (setf (compiland-lambda-expression compiland)
482                `(lambda ,lambda-list ,@decls (block ,name ,@body))))
483        (push variable *all-variables*)
484        (push local-function local-functions)))
485    (setf local-functions (nreverse local-functions))
486    ;; Make the local functions visible.
487    (dolist (local-function local-functions)
488      (push local-function *local-functions*)
489      (push (local-function-variable local-function) *visible-variables*))
490    (dolist (local-function local-functions)
491      (let ((*visible-variables* *visible-variables*)
492            (*current-compiland* (local-function-compiland local-function)))
493        (p1-compiland (local-function-compiland local-function))))
494    (list* (car form) local-functions (mapcar #'p1 (cddr form)))))
495
496(defun p1-function (form)
497  (let (local-function)
498    (cond ((and (consp (cadr form)) (eq (caadr form) 'LAMBDA))
499           (when *current-compiland*
500             (incf (compiland-children *current-compiland*)))
501           (let* ((*current-compiland* *current-compiland*)
502                  (lambda-form (cadr form))
503                  (lambda-list (cadr lambda-form))
504                  (body (cddr lambda-form))
505                  (compiland (make-compiland :name (gensym "ANONYMOUS-LAMBDA-")
506                                             :lambda-expression lambda-form
507                                             :parent *current-compiland*)))
508             (multiple-value-bind (body decls)
509               (sys::parse-body body)
510               (setf (compiland-lambda-expression compiland)
511                     `(lambda ,lambda-list ,@decls (block nil ,@body)))
512               (let ((*visible-variables* *visible-variables*)
513                     (*current-compiland* compiland))
514                 (p1-compiland compiland)))
515             (list 'FUNCTION compiland)))
516          ((setf local-function (find-local-function (cadr form)))
517           (dformat t "p1-function local function ~S~%" (cadr form))
518           (let ((variable (local-function-variable local-function)))
519             (when variable
520               (unless (or (eq (variable-compiland variable) *current-compiland*)
521                           (eq (local-function-compiland local-function) *current-compiland*))
522                 (dformat t "p1-function ~S used non-locally~%" (variable-name variable))
523                 (setf (variable-used-non-locally-p variable) t))))
524           form)
525          (t
526           form))))
527
528(defun p1-lambda (form)
529  (let* ((lambda-list (cadr form))
530         (body (cddr form))
531         (auxvars (memq '&AUX lambda-list)))
532    (when auxvars
533      (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
534      (setf body (list (append (list 'LET* (cdr auxvars)) body))))
535    (p1-function (list 'FUNCTION (list* 'LAMBDA lambda-list body)))))
536
537(defun p1-eval-when (form)
538  (list* (car form) (cadr form) (mapcar #'p1 (cddr form))))
539
540(defun p1-quote (form)
541  (if (numberp (second form))
542      (second form)
543      form))
544
545(defun p1-setq (form)
546  (unless (= (length form) 3)
547    (error "Too many arguments for SETQ."))
548  (let ((arg1 (second form))
549        (arg2 (third form)))
550    (let ((variable (find-visible-variable arg1)))
551      (if variable
552          (progn
553            (incf (variable-writes variable))
554            (cond
555             ((eq (variable-compiland variable) *current-compiland*)
556              (dformat t "p1-setq: write ~S~%" arg1))
557             (t
558              (dformat t "p1-setq: non-local write ~S~%" arg1)
559              (setf (variable-used-non-locally-p variable) t))))
560          (dformat t "p1-setq: unknown variable ~S~%" arg1)))
561    (list 'SETQ arg1 (p1 arg2))))
562
563(defun p1-the (form)
564  (dformat t "p1-the form = ~S~%" form)
565  (let ((type (second form))
566        (expr (third form)))
567    (cond
568     ((and (listp type) (eq (car type) 'VALUES))
569      ;; FIXME
570      (p1 expr))
571     ((= *safety* 3)
572      (dformat t "p1-the expr = ~S~%" expr)
573      (let* ((sym (gensym))
574             (new-expr
575              `(let ((,sym ,expr))
576                 (sys::require-type ,sym ',type)
577                 ,sym)))
578        (dformat t "p1-the new-expr = ~S~%" new-expr)
579        (p1 new-expr)))
580     (t
581      (dformat t "p1-the t case expr = ~S~%" expr)
582      (if (subtypep type 'FIXNUM)
583          (list 'THE type (p1 expr))
584          (p1 expr))))))
585
586(defun p1-default (form)
587  (list* (car form) (mapcar #'p1 (cdr form))))
588
589(defun p1-throw (form)
590  (let ((new-form (rewrite-throw form)))
591    (when (neq new-form form)
592      (return-from p1-throw (p1 new-form))))
593  (list* 'THROW (mapcar #'p1 (cdr form))))
594
595(defun expand-inline (form expansion)
596  (let ((args (cdr form))
597        (vars (cadr expansion))
598        (varlist ())
599        new-form)
600    (do ((vars vars (cdr vars))
601         (args args (cdr args)))
602        ((null vars))
603      (push (list (car vars) (car args)) varlist))
604    (setf varlist (nreverse varlist))
605    (setf new-form (list* 'LET varlist (cddr expansion)))
606    new-form))
607
608(defun p1 (form)
609  (cond
610   ((symbolp form)
611    (cond
612     ((constantp form) ; a DEFCONSTANT
613      (let ((value (symbol-value form)))
614        (if (numberp value)
615            value
616            form)))
617     ((keywordp form)
618      form)
619     (t
620      (let ((variable (find-visible-variable form)))
621        (if variable
622            (progn
623              (incf (variable-reads variable))
624              (cond
625               ((eq (variable-compiland variable) *current-compiland*)
626                (dformat t "p1: read ~S~%" form))
627               (t
628                (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%"
629                         form
630                         (compiland-name (variable-compiland variable))
631                         (compiland-name *current-compiland*))
632                (setf (variable-used-non-locally-p variable) t))))
633            (dformat t "p1: unknown variable ~S~%" form)))
634      form)))
635   ((atom form)
636    form)
637   (t
638    (let ((op (car form))
639          handler)
640      (cond ((symbolp op)
641             (cond ((setf handler (get op 'p1-handler))
642                    (funcall handler form))
643                   ((macro-function op)
644                    (p1 (macroexpand form)))
645                   ((special-operator-p op)
646                    (error "P1: unsupported special operator ~S" op))
647                   (t
648                    ;; Function call.
649                    (let ((new-form (rewrite-function-call form)))
650                      (when (neq new-form form)
651                        (dformat t "old form = ~S~%" form)
652                        (dformat t "new form = ~S~%" new-form)
653                        (return-from p1 (p1 new-form))))
654                    (let ((source-transform (source-transform op)))
655                      (when source-transform
656                        (let ((new-form (expand-source-transform form)))
657                          (when (neq new-form form)
658                            (return-from p1 (p1 new-form))))))
659                    (let ((expansion (inline-expansion op)))
660                      (when expansion
661                        (return-from p1 (p1 (expand-inline form expansion)))))
662                    (let ((local-function (find-local-function op)))
663                      (when local-function
664                        (dformat t "p1 local function ~S~%" op)
665                        (unless (eq (local-function-compiland local-function)
666                                    *current-compiland*)
667                          (let ((variable (local-function-variable local-function)))
668                            (when variable
669                              (unless (eq (variable-compiland variable) *current-compiland*)
670                                (dformat t "p1 ~S used non-locally~%" (variable-name variable))
671                                (setf (variable-used-non-locally-p variable) t)))))))
672                    (list* op (mapcar #'p1 (cdr form)))
673                    )))
674            ((and (consp op) (eq (car op) 'LAMBDA))
675             (p1 (list* 'FUNCALL form)))
676            (t
677             form))))))
678
679(defun install-p1-handler (symbol handler)
680  (setf (get symbol 'p1-handler) handler))
681
682(install-p1-handler 'block                'p1-block)
683(install-p1-handler 'catch                'p1-default)
684(install-p1-handler 'declare              'identity)
685(install-p1-handler 'eval-when            'p1-eval-when)
686(install-p1-handler 'flet                 'p1-flet)
687(install-p1-handler 'function             'p1-function)
688(install-p1-handler 'go                   'p1-go)
689(install-p1-handler 'if                   'p1-default)
690(install-p1-handler 'labels               'p1-labels)
691(install-p1-handler 'lambda               'p1-lambda)
692(install-p1-handler 'let                  'p1-let/let*)
693(install-p1-handler 'let*                 'p1-let/let*)
694(install-p1-handler 'load-time-value      'identity)
695(install-p1-handler 'locally              'p1-default)
696(install-p1-handler 'multiple-value-bind  'p1-m-v-b)
697(install-p1-handler 'multiple-value-call  'p1-default)
698(install-p1-handler 'multiple-value-list  'p1-default)
699(install-p1-handler 'multiple-value-prog1 'p1-default)
700(install-p1-handler 'progn                'p1-default)
701(install-p1-handler 'progv                'identity)
702(install-p1-handler 'quote                'p1-quote)
703(install-p1-handler 'return-from          'p1-return-from)
704(install-p1-handler 'setq                 'p1-setq)
705(install-p1-handler 'symbol-macrolet      'identity)
706(install-p1-handler 'tagbody              'p1-tagbody)
707(install-p1-handler 'the                  'p1-the)
708(install-p1-handler 'throw                'p1-throw)
709(install-p1-handler 'unwind-protect       'p1-default)
710
711(defun dump-pool ()
712  (let ((pool (reverse *pool*))
713        entry type)
714    (dotimes (index (1- *pool-count*))
715      (setq entry (car pool))
716      (setq type (case (car entry)
717                   (7 'class)
718                   (9 'field)
719                   (10 'method)
720                   (11 'interface)
721                   (8 'string)
722                   (3 'integer)
723                   (4 'float)
724                   (5 'long)
725                   (6 'double)
726                   (12 'name-and-type)
727                   (1 'utf8)))
728      (%format t "~D: ~A ~S~%" (1+ index) type entry)
729      (setq pool (cdr pool))))
730  t)
731
732(defun pool-get (entry)
733  (declare (optimize speed))
734  (let ((index (gethash entry *pool-entries*)))
735    (unless index
736      (setf index *pool-count*)
737      (push entry *pool*)
738      (setf (gethash entry *pool-entries*) index)
739      (setf *pool-count* (1+ index)))
740    index))
741
742(defun pool-name (name)
743  (declare (optimize speed))
744  (pool-get (list 1 (length name) name)))
745
746(defun pool-name-and-type (name type)
747  (declare (optimize speed))
748  (pool-get (list 12
749                  (pool-name name)
750                  (pool-name type))))
751
752;; Assumes CLASS-NAME is already in the correct form ("org/armedbear/lisp/Lisp"
753;; as opposed to "org.armedbear.lisp.Lisp").
754(defun pool-class (class-name)
755  (declare (optimize speed))
756  (pool-get (list 7 (pool-name class-name))))
757
758;; (tag class-index name-and-type-index)
759(defun pool-field (class-name field-name type-name)
760  (declare (optimize speed))
761  (pool-get (list 9
762                  (pool-class class-name)
763                  (pool-name-and-type field-name type-name))))
764
765;; (tag class-index name-and-type-index)
766(defun pool-method (class-name method-name type-name)
767  (declare (optimize speed))
768  (pool-get (list 10
769                  (pool-class class-name)
770                  (pool-name-and-type method-name type-name))))
771
772(defun pool-string (string)
773  (declare (optimize speed))
774  (pool-get (list 8 (pool-name string))))
775
776(defun pool-int (n)
777  (declare (optimize speed))
778  (pool-get (list 3 n)))
779
780(defun u2 (n)
781  (declare (optimize speed))
782  (declare (type fixnum n))
783  (list (logand (ash n -8) #xff)
784        (logand n #xff)))
785
786(locally (declare (optimize speed))
787  (defstruct (instruction
788              (:constructor make-instruction (opcode args)))
789    opcode
790    args
791    stack
792    depth))
793
794(defun print-instruction (instruction)
795  (%format nil "~A ~A stack = ~S depth = ~S"
796          (opcode-name (instruction-opcode instruction))
797          (instruction-args instruction)
798          (instruction-stack instruction)
799          (instruction-depth instruction)))
800
801(defun inst (instr &optional args)
802  (let ((opcode (if (numberp instr)
803                    instr
804                    (opcode-number instr))))
805    (unless (listp args)
806      (setf args (list args)))
807    (make-instruction opcode args)))
808
809(defun emit (instr &rest args)
810  (declare (optimize speed))
811  (let ((instruction (inst instr args)))
812    (push instruction *code*)
813    instruction))
814
815(defun label (symbol)
816  (declare (optimize speed))
817  (emit 'label symbol)
818  (setf (symbol-value symbol) nil))
819
820(defconstant +java-string+ "Ljava/lang/String;")
821(defconstant +lisp-class+ "org/armedbear/lisp/Lisp")
822(defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject")
823(defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;")
824(defconstant +lisp-string+ "Lorg/armedbear/lisp/SimpleString;")
825(defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol")
826(defconstant +lisp-symbol+ "Lorg/armedbear/lisp/Symbol;")
827(defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread")
828(defconstant +lisp-thread+ "Lorg/armedbear/lisp/LispThread;")
829(defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons")
830(defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum")
831(defconstant +lisp-fixnum+ "Lorg/armedbear/lisp/Fixnum;")
832(defconstant +lisp-simple-string-class+ "org/armedbear/lisp/SimpleString")
833(defconstant +lisp-simple-string+ "Lorg/armedbear/lisp/SimpleString;")
834(defconstant +lisp-environment+ "Lorg/armedbear/lisp/Environment;")
835(defconstant +lisp-binding+ "Lorg/armedbear/lisp/Binding;")
836(defconstant +lisp-throw-class+ "org/armedbear/lisp/Throw")
837(defconstant +lisp-return-class+ "org/armedbear/lisp/Return")
838(defconstant +lisp-go-class+ "org/armedbear/lisp/Go")
839(defconstant +lisp-ctf-class+ "org/armedbear/lisp/ClosureTemplateFunction")
840
841(defsubst emit-push-nil ()
842  (emit 'getstatic +lisp-class+ "NIL" +lisp-object+))
843
844(defsubst emit-push-t ()
845  (emit 'getstatic +lisp-class+ "T" +lisp-symbol+))
846
847(defun emit-push-constant-int (n)
848  (if (<= -32768 n 32767)
849      (emit 'sipush n)
850      (emit 'ldc (pool-int n))))
851
852(defun make-descriptor (arg-types return-type)
853  (with-output-to-string (s)
854    (princ #\( s)
855    (dolist (type arg-types)
856      (princ type s))
857    (princ #\) s)
858    (princ (if return-type return-type "V") s)))
859
860(defun descriptor (designator)
861  (cond ((stringp designator)
862         designator)
863        ((listp designator)
864         (unless (= (length designator) 2)
865           (error "Bad method type descriptor ~S." designator))
866         (make-descriptor (car designator) (cadr designator)))
867        (t
868         (error "Bad method type descriptor ~S." designator))))
869
870(defun emit-invokestatic (class-name method-name descriptor stack)
871  (aver stack)
872  (let ((instruction (emit 'invokestatic
873                           class-name method-name (descriptor descriptor))))
874    (setf (instruction-stack instruction) stack)
875    (aver (eql (instruction-stack instruction) stack))))
876
877(defun emit-invokespecial (class-name method-name descriptor stack)
878  (let ((instruction (emit 'invokespecial
879                           class-name method-name (descriptor descriptor))))
880    (setf (instruction-stack instruction) stack)))
881
882(defun emit-invokevirtual (class-name method-name descriptor stack)
883  (let ((instruction (emit 'invokevirtual
884                           class-name method-name (descriptor descriptor))))
885    (setf (instruction-stack instruction) stack)))
886
887;; Index of local variable used to hold the current thread.
888(defvar *thread* nil)
889
890(defvar *initialize-thread-var* nil)
891
892(defun maybe-initialize-thread-var ()
893  (when *initialize-thread-var*
894    (emit-invokestatic +lisp-thread-class+
895                       "currentThread"
896                       (make-descriptor () +lisp-thread+)
897                       1)
898    (emit 'astore *thread*)))
899
900(defsubst ensure-thread-var-initialized ()
901  (setf *initialize-thread-var* t))
902
903(defun emit-push-current-thread ()
904  (declare (optimize speed))
905  (ensure-thread-var-initialized)
906  (emit 'aload *thread*))
907
908(defun maybe-generate-arg-count-check ()
909  (when *arity*
910    (let ((label1 (gensym)))
911      (aver (fixnump *arity*))
912      (aver (not (minusp *arity*)))
913      (emit 'aload 1)
914      (emit 'arraylength)
915      (emit 'bipush *arity*)
916      (emit 'if_icmpeq `,label1)
917      (emit 'aload 0) ; this
918      (emit-invokevirtual *this-class*
919                          "argCountError"
920                          "()V"
921                          -1)
922      (emit 'label `,label1))))
923
924(defun maybe-generate-interrupt-check ()
925  (unless (> *speed* *safety*)
926    (let ((label1 (gensym)))
927      (emit 'getstatic +lisp-class+ "interrupted" "Z")
928      (emit 'ifeq `,label1)
929      (emit-invokestatic +lisp-class+
930                         "handleInterrupt"
931                         "()V"
932                         0)
933      (emit 'label `,label1))))
934
935(defun single-valued-p-init ()
936  (dolist (op '(+ - * /
937                1+ 1- < > <= >= = /=
938                car cdr caar cadr cdar cddr cadar caddr cdddr cddddr
939                first second third
940                eq eql equal equalp
941                length
942                constantp symbolp
943                list list*
944                macro-function
945                compiler-macro-function
946                sys::%defun
947                get
948                atom
949                compiled-function-p
950                fdefinition
951                special-operator-p keywordp functionp fboundp zerop consp listp
952                numberp integerp floatp
953                plusp minusp
954                complexp arrayp readtablep packagep
955                array-dimensions array-rank array-total-size
956                array-element-type upgraded-array-element-type
957                simple-vector-p simple-string-p bit-vector-p simple-bit-vector-p
958                stringp
959                row-major-aref
960                quote function
961                mapcar
962                find position
963                append nconc subseq adjoin
964                revappend nreconc
965                copy-seq
966                assoc assoc-if assoc-if-not acons assq assql
967                char-code code-char char-int digit-char-p
968                member ext:memq
969                remove remove-if remove-if-not delete delete-if delete-if-not
970                special-variable-p
971                gensym
972                symbol-name symbol-function
973                coerce
974                reverse nreverse
975                last
976                cons rplaca rplacd
977                sys::%rplaca sys::%rplacd
978                copy-list copy-tree
979                make-sequence make-list make-array make-package make-hash-table
980                make-string
981                find-package
982                pathname make-pathname pathname-name directory
983                package-used-by-list package-shadowing-symbols
984                nthcdr
985                aref elt
986                not null endp
987                concatenate
988                format sys::%format
989                prin1 princ print write
990                compute-restarts find-restart restart-name
991                string
992                string=
993                setq
994                multiple-value-list push pop
995                type-of class-of
996                typep sys::%typep
997                abs
998                ash
999                float-radix
1000                logand logandc1 logandc2 logeqv logior lognand
1001                lognot logorc1 logorc2 logxor
1002                logbitp
1003                slot-boundp slot-value slot-exists-p
1004                allocate-instance
1005                find-class
1006                class-name
1007                constantly
1008                exp expt log
1009                min max
1010                realpart imagpart
1011                integer-length
1012                sqrt isqrt gcd lcm signum
1013                char schar
1014                open
1015                svref
1016                fill-pointer
1017                symbol-value symbol-package package-name
1018                fourth
1019                vector-push vector-push-extend
1020                union nunion
1021                remove-duplicates delete-duplicates
1022                read-byte
1023                fresh-line terpri
1024                lambda
1025                ext:classp
1026                ext:fixnump
1027                ext:memql
1028                sys::generic-function-name
1029                sys::puthash
1030                precompiler::precompile1
1031                declare
1032                go
1033                sys::%structure-ref
1034                inst
1035                emit
1036                label
1037                maybe-emit-clear-values
1038                single-valued-p
1039                sys:single-valued-p
1040                sys:write-8-bits
1041                ))
1042    (setf (sys:single-valued-p op) t)))
1043
1044(eval-when (:load-toplevel :execute)
1045  (single-valued-p-init))
1046
1047(defun single-valued-p (form)
1048  (cond ((block-node-p form)
1049         (if (equal (block-name form) '(TAGBODY))
1050             t
1051             (single-valued-p (node-form form))))
1052        ((atom form)
1053         t)
1054        ((eq (first form) 'IF)
1055         (and ;;(single-valued-p (second form))
1056              (single-valued-p (third form))
1057              (single-valued-p (fourth form))))
1058        ((eq (first form) 'PROGN)
1059         (single-valued-p (car (last form))))
1060        ((memq (first form) '(LET LET*))
1061         (single-valued-p (car (last (cddr form)))))
1062        ((memq (car form) '(AND OR))
1063         (every #'single-valued-p (cdr form)))
1064        ((eq (first form) 'RETURN-FROM)
1065         (single-valued-p (third form)))
1066        (t
1067         (sys:single-valued-p (car form)))))
1068
1069(defun emit-clear-values ()
1070;;   (break "EMIT-CLEAR-VALUES called~%")
1071  (ensure-thread-var-initialized)
1072  (emit 'clear-values))
1073
1074(defun maybe-emit-clear-values (form)
1075  (declare (optimize speed))
1076  (unless (single-valued-p form)
1077;;     (format t "Not single-valued: ~S~%" form)
1078    (ensure-thread-var-initialized)
1079    (emit 'clear-values)))
1080
1081(defun emit-unbox-fixnum ()
1082  (declare (optimize speed))
1083  (cond ((= *safety* 3)
1084         (emit-invokestatic +lisp-fixnum-class+
1085                            "getValue"
1086                            "(Lorg/armedbear/lisp/LispObject;)I"
1087                            0))
1088        (t
1089         (emit 'checkcast +lisp-fixnum-class+)
1090         (emit 'getfield +lisp-fixnum-class+ "value" "I"))))
1091
1092(defun emit-box-long ()
1093  (declare (optimize speed))
1094  (emit-invokestatic +lisp-class+
1095                     "number"
1096                     "(J)Lorg/armedbear/lisp/LispObject;"
1097                     -1))
1098
1099;; Expects value on stack.
1100(defun emit-invoke-method (method-name target representation)
1101  (emit-invokevirtual +lisp-object-class+
1102                      method-name
1103                      "()Lorg/armedbear/lisp/LispObject;"
1104                      0)
1105  (when (eq representation :unboxed-fixnum)
1106    (emit-unbox-fixnum))
1107  (emit-move-from-stack target representation))
1108
1109(defvar *style-warnings* nil)
1110(defvar *warnings* nil)
1111(defvar *errors* nil)
1112
1113(defun compiler-style-warn (format-control &rest format-arguments)
1114  (incf *style-warnings*)
1115  (warn 'style-warning
1116        :format-control format-control
1117        :format-arguments format-arguments))
1118
1119(defun compiler-warn (format-control &rest format-arguments)
1120  (incf *warnings*)
1121  (warn 'warning
1122        :format-control format-control
1123        :format-arguments format-arguments))
1124
1125(defun check-args (form n)
1126  (declare (type fixnum n))
1127  (cond ((= (length form) (1+ n))
1128         t)
1129        (t
1130         (compiler-style-warn "Wrong number of arguments for ~A." (car form))
1131         nil)))
1132
1133(defparameter *resolvers* (make-hash-table :test #'eql))
1134
1135(defun unsupported-opcode (instruction)
1136  (error "Unsupported opcode ~D."
1137         (instruction-opcode instruction)))
1138
1139(dotimes (n (1+ *last-opcode*))
1140  (setf (gethash n *resolvers*) #'unsupported-opcode))
1141
1142;; The following opcodes resolve to themselves.
1143(dolist (n '(0 ; NOP
1144             1 ; ACONST_NULL
1145             2 ; ICONST_M1
1146             3 ; ICONST_0
1147             4 ; ICONST_1
1148             5 ; ICONST_2
1149             6 ; ICONST_3
1150             7 ; ICONST_4
1151             8 ; ICONST_5
1152             42 ; ALOAD_0
1153             43 ; ALOAD_1
1154             44 ; ALOAD_2
1155             45 ; ALOAD_3
1156             50 ; AALOAD
1157             75 ; ASTORE_0
1158             76 ; ASTORE_1
1159             77 ; ASTORE_2
1160             78 ; ASTORE_3
1161             83 ; AASTORE
1162             87 ; POP
1163             89 ; DUP
1164             90 ; DUP_X1
1165             91 ; DUP_X2
1166             95 ; SWAP
1167             96 ; IADD
1168             97 ; LADD
1169             101 ; LSUB
1170             116 ; INEG
1171             120 ; ISHL
1172             121 ; LSHL
1173             122 ; ISHR
1174             123 ; LSHR
1175             126 ; IAND
1176             132 ; IINC
1177             133 ; I2L
1178             136 ; L2I
1179             153 ; IFEQ
1180             154 ; IFNE
1181             155 ; IFGE
1182             156 ; IFGT
1183             157 ; IFGT
1184             158 ; IFLE
1185             159 ; IF_ICMPEQ
1186             160 ; IF_ICMPNE
1187             161 ; IF_ICMPLT
1188             162 ; IF_ICMPGE
1189             163 ; IF_ICMPGT
1190             164 ; IF_ICMPLE
1191             165 ; IF_ACMPEQ
1192             166 ; IF_ACMPNE
1193             167 ; GOTO
1194             168 ; JSR
1195             169 ; RET
1196             176 ; ARETURN
1197             177 ; RETURN
1198             190 ; ARRAYLENGTH
1199             191 ; ATHROW
1200             198 ; IFNULL
1201             202 ; LABEL
1202             ))
1203  (setf (gethash n *resolvers*) nil))
1204
1205(defmacro define-resolver (opcodes args &body body)
1206  (let ((name (gensym)))
1207    (if (listp opcodes)
1208        `(progn
1209           (defun ,name ,args ,@body)
1210           (eval-when (:load-toplevel :execute)
1211             (dolist (op ',opcodes)
1212               (setf (gethash op *resolvers*) (symbol-function ',name)))))
1213        `(progn
1214           (defun ,name ,args ,@body)
1215           (eval-when (:load-toplevel :execute)
1216             (setf (gethash ,opcodes *resolvers*) (symbol-function ',name)))))))
1217
1218;; ALOAD
1219(define-resolver 25 (instruction)
1220 (let* ((args (instruction-args instruction))
1221        (index (car args)))
1222   (cond ((<= 0 index 3)
1223          (inst (+ index 42)))
1224         ((<= 0 index 255)
1225          (inst 25 index))
1226         (t
1227          (error "ALOAD unsupported case")))))
1228
1229;; ILOAD
1230(define-resolver 21 (instruction)
1231  (let* ((args (instruction-args instruction))
1232         (index (car args)))
1233    (cond ((<= 0 index 3)
1234           (inst (+ index 26)))
1235          ((<= 0 index 255)
1236           (inst 21 index))
1237          (t
1238           (error "ILOAD unsupported case")))))
1239
1240;; ASTORE
1241(define-resolver 58 (instruction)
1242  (let* ((args (instruction-args instruction))
1243         (index (car args)))
1244    (cond ((<= 0 index 3)
1245           (inst (+ index 75)))
1246          ((<= 0 index 255)
1247           (inst 58 index))
1248          (t
1249           (error "ASTORE unsupported case")))))
1250
1251;; ISTORE
1252(define-resolver 54 (instruction)
1253  (let* ((args (instruction-args instruction))
1254         (index (car args)))
1255    (cond ((<= 0 index 3)
1256           (inst (+ index 59)))
1257          ((<= 0 index 255)
1258           (inst 54 index))
1259          (t
1260           (error "ASTORE unsupported case")))))
1261
1262;; GETSTATIC, PUTSTATIC
1263(define-resolver (178 179) (instruction)
1264  (let* ((args (instruction-args instruction))
1265         (index (pool-field (first args) (second args) (third args))))
1266    (inst (instruction-opcode instruction) (u2 index))))
1267
1268;; BIPUSH, SIPUSH
1269(define-resolver (16 17) (instruction)
1270  (let* ((args (instruction-args instruction))
1271         (n (first args)))
1272    (cond ((<= 0 n 5)
1273           (inst (+ n 3)))
1274          ((<= -128 n 127)
1275           (inst 16 (logand n #xff))) ; BIPUSH
1276          (t ; SIPUSH
1277           (inst 17 (u2 n))))))
1278
1279;; INVOKEVIRTUAL, INVOKESPECIAL, INVOKESTATIC class-name method-name descriptor
1280(define-resolver (182 183 184) (instruction)
1281  (let* ((args (instruction-args instruction))
1282         (index (pool-method (first args) (second args) (third args))))
1283    (setf (instruction-args instruction) (u2 index))
1284    instruction))
1285
1286;; LDC
1287(define-resolver 18 (instruction)
1288  (let* ((args (instruction-args instruction)))
1289    (unless (= (length args) 1)
1290      (error "Wrong number of args for LDC."))
1291    (if (> (car args) 255)
1292        (inst 19 (u2 (car args))) ; LDC_W
1293        (inst 18 args))))
1294
1295;; GETFIELD, PUTFIELD class-name field-name type-name
1296(define-resolver (180 181) (instruction)
1297  (let* ((args (instruction-args instruction))
1298         (index (pool-field (first args) (second args) (third args))))
1299    (inst (instruction-opcode instruction) (u2 index))))
1300
1301;; NEW, ANEWARRAY, CHECKCAST, INSTANCEOF class-name
1302(define-resolver (187 189 192 193) (instruction)
1303  (let* ((args (instruction-args instruction))
1304         (index (pool-class (first args))))
1305    (inst (instruction-opcode instruction) (u2 index))))
1306
1307(defun resolve-instruction (instruction)
1308  (declare (optimize speed))
1309  (let ((resolver (gethash (instruction-opcode instruction) *resolvers*)))
1310    (if resolver
1311        (funcall resolver instruction)
1312        instruction)))
1313
1314(defun resolve-instructions (code)
1315  (let ((vector (make-array 512 :fill-pointer 0 :adjustable t)))
1316    (dotimes (index (the fixnum (length code)) vector)
1317      (declare (type fixnum index))
1318      (let ((instruction (svref code index)))
1319        (case (instruction-opcode instruction)
1320          (205 ; CLEAR-VALUES
1321           (let ((instructions
1322                  (list
1323                   (inst 'aload *thread*)
1324                   (inst 'aconst_null)
1325                   (inst 'putfield (list +lisp-thread-class+ "_values"
1326                                         "[Lorg/armedbear/lisp/LispObject;")))))
1327             (dolist (instruction instructions)
1328               (vector-push-extend (resolve-instruction instruction) vector))))
1329          (t
1330           (vector-push-extend (resolve-instruction instruction) vector)))))))
1331
1332(defconstant +branch-opcodes+
1333  '(153 ; IFEQ
1334    154 ; IFNE
1335    155 ; IFLT
1336    156 ; IFGE
1337    157 ; IFGT
1338    158 ; IFLE
1339    159 ; IF_ICMPEQ
1340    160 ; IF_ICMPNE
1341    161 ; IF_ICMPLT
1342    162 ; IF_ICMPGE
1343    163 ; IF_ICMPGT
1344    164 ; IF_ICMPLE
1345    165 ; IF_ACMPEQ
1346    166 ; IF_ACMPNE
1347    167 ; GOTO
1348    168 ; JSR
1349    198 ; IFNULL
1350    ))
1351
1352(defsubst branch-opcode-p (opcode)
1353  (declare (optimize speed))
1354  (member opcode +branch-opcodes+))
1355
1356(defun walk-code (code start-index depth)
1357  (declare (optimize speed))
1358  (do* ((i start-index (1+ i))
1359        (limit (length code)))
1360       ((>= i limit))
1361    (declare (type fixnum i limit))
1362    (let ((instruction (aref code i)))
1363      (when (instruction-depth instruction)
1364        (unless (eql (instruction-depth instruction) (+ depth (instruction-stack instruction)))
1365          (fresh-line)
1366          (%format t "Stack inconsistency at index ~D: found ~S, expected ~S.~%"
1367                   i
1368                   (instruction-depth instruction)
1369                   (+ depth (instruction-stack instruction))))
1370        (return-from walk-code))
1371      (let ((opcode (instruction-opcode instruction)))
1372        (unless (eql opcode 168) ; JSR
1373          (setf depth (+ depth (instruction-stack instruction))))
1374        (setf (instruction-depth instruction) depth)
1375        (if (eql opcode 168) ; JSR
1376            (let ((label (car (instruction-args instruction))))
1377              (walk-code code (symbol-value label) (1+ depth)))
1378            (when (branch-opcode-p opcode)
1379              (let ((label (car (instruction-args instruction))))
1380                (walk-code code (symbol-value label) depth))))
1381        (when (member opcode '(167 169 191)) ; GOTO RET ATHROW
1382          ;; Current path ends.
1383          (return-from walk-code))))))
1384
1385(defun analyze-stack ()
1386  (let* ((code *code*)
1387         (code-length (length code)))
1388    (declare (type fixnum code-length))
1389    (aver (vectorp code))
1390    (dotimes (i code-length)
1391      (declare (type fixnum i))
1392      (let* ((instruction (aref code i))
1393             (opcode (instruction-opcode instruction)))
1394        (when (eql opcode 202) ; LABEL
1395          (let ((label (car (instruction-args instruction))))
1396            (set label i)))
1397        (if (instruction-stack instruction)
1398            (when (opcode-stack-effect opcode)
1399              (unless (eql (instruction-stack instruction) (opcode-stack-effect opcode))
1400                (%format t "instruction-stack = ~S opcode-stack-effect = ~S~%"
1401                         (instruction-stack instruction)
1402                         (opcode-stack-effect opcode))
1403                (%format t "index = ~D instruction = ~A~%" i (print-instruction instruction))))
1404            (setf (instruction-stack instruction) (opcode-stack-effect opcode)))
1405;;         (aver (not (null (instruction-stack instruction))))
1406        (unless (instruction-stack instruction)
1407          (%format t "no stack information for instruction ~D~%" (instruction-opcode instruction))
1408          (aver nil))))
1409    (walk-code code 0 0)
1410    (dolist (handler *handlers*)
1411      ;; Stack depth is always 1 when handler is called.
1412      (walk-code code (symbol-value (handler-code handler)) 1))
1413    (let ((max-stack 0))
1414      (dotimes (i code-length)
1415        (declare (type fixnum i))
1416        (let* ((instruction (aref code i))
1417               (depth (instruction-depth instruction)))
1418          (when depth
1419            (setf max-stack (max max-stack depth)))))
1420      (when *compiler-debug*
1421        (%format t "compiland name = ~S~%" (compiland-name *current-compiland*))
1422        (%format t "max-stack = ~D~%" max-stack)
1423        (%format t "----- after stack analysis -----~%")
1424        (print-code))
1425      max-stack)))
1426
1427(defun emit-move-from-stack (target &optional representation)
1428  (declare (optimize speed))
1429  (cond ((null target)
1430         (emit 'pop))
1431        ((eq target :stack))
1432        ((fixnump target)
1433         (emit (if (eq representation :unboxed-fixnum) 'istore 'astore) target))
1434        (t
1435         (aver nil))))
1436
1437(defun resolve-variables ()
1438  (let ((code (nreverse *code*)))
1439    (setf *code* nil)
1440    (dolist (instruction code)
1441      (case (instruction-opcode instruction)
1442        (206 ; VAR-REF
1443         (let* ((instruction-args (instruction-args instruction))
1444                (variable (first instruction-args))
1445                (target (second instruction-args))
1446                (representation (third instruction-args)))
1447           (aver (variable-p variable))
1448           (cond
1449            ((variable-register variable)
1450             (dformat t "variable = ~S register = ~S~%"
1451                      (variable-name variable)
1452                      (variable-register variable))
1453             (emit 'aload (variable-register variable))
1454             (emit-move-from-stack target))
1455            ((variable-special-p variable)
1456             (compile-special-reference (variable-name variable) target nil))
1457            ((variable-closure-index variable)
1458             (dformat t "variable = ~S closure-index = ~S~%"
1459                      (variable-name variable) (variable-closure-index variable))
1460             (aver (not (null (compiland-closure-register *current-compiland*))))
1461             (emit 'aload (compiland-closure-register *current-compiland*))
1462             (emit 'bipush (variable-closure-index variable))
1463             (emit 'aaload)
1464             (emit-move-from-stack target))
1465            ((variable-index variable)
1466             (aver (not (null (compiland-argument-register *current-compiland*))))
1467             (emit 'aload (compiland-argument-register *current-compiland*))
1468             (emit-push-constant-int (variable-index variable))
1469             (emit 'aaload)
1470             (emit-move-from-stack target))
1471            (t
1472             (dformat t "VAR-REF unhandled case variable = ~S~%" (variable-name variable))
1473             (aver (progn 'unhandled-case nil))))
1474           (when (eq representation :unboxed-fixnum)
1475             (dformat t "resolve-variables calling emit-unbox-fixnum~%")
1476             (emit-unbox-fixnum))))
1477        (207 ; VAR-SET
1478         (let ((variable (car (instruction-args instruction))))
1479           (dformat t "var-set var = ~S reg = ~S closure index = ~S~%"
1480                    (variable-name variable)
1481                    (variable-register variable)
1482                    (variable-closure-index variable)
1483                    )
1484           (aver (variable-p variable))
1485           (aver (not (variable-special-p variable)))
1486           (cond ((variable-register variable)
1487                  (emit 'astore (variable-register variable)))
1488                 ((variable-closure-index variable)
1489                  (dformat t "variable = ~S closure-index = ~S~%"
1490                           (variable-name variable) (variable-closure-index variable))
1491                  (aver (not (null (compiland-closure-register *current-compiland*))))
1492                  (emit 'aload (compiland-closure-register *current-compiland*))
1493                  (emit 'swap) ; array value
1494                  (emit 'bipush (variable-closure-index variable))
1495                  (emit 'swap) ; array index value
1496                  (emit 'aastore)
1497                  )
1498                 (t
1499                  (dformat t "var-set fall-through case~%")
1500                  (aver (not (null (compiland-argument-register *current-compiland*))))
1501                  (emit 'aload (compiland-argument-register *current-compiland*)) ; Stack: value array
1502                  (emit 'swap) ; array value
1503                  (emit 'bipush (variable-index variable)) ; array value index
1504                  (emit 'swap) ; array index value
1505                  (emit 'aastore)))))
1506        (t
1507         (push instruction *code*))))))
1508
1509(defun finalize-code ()
1510  (setf *code* (nreverse (coerce *code* 'vector))))
1511
1512(defun print-code()
1513  (dotimes (i (length *code*))
1514    (let ((instruction (aref *code* i)))
1515      (%format t "~D ~A ~S ~S ~S~%"
1516               i
1517               (opcode-name (instruction-opcode instruction))
1518               (instruction-args instruction)
1519               (instruction-stack instruction)
1520               (instruction-depth instruction)))))
1521
1522(defun validate-labels (code)
1523  (let ((code (coerce code 'list))
1524        (i 0))
1525    (dolist (instruction code)
1526      (when (eql (instruction-opcode instruction) 202) ; LABEL
1527        (let ((label (car (instruction-args instruction))))
1528          (set label i)))
1529      (incf i))))
1530
1531;; Remove unused labels.
1532(defun optimize-1 ()
1533  (let ((code (coerce *code* 'list))
1534        (changed nil)
1535        (marker (gensym)))
1536    ;; Mark the labels that are actually branched to.
1537    (dolist (instruction code)
1538      (when (branch-opcode-p (instruction-opcode instruction))
1539        (let ((label (car (instruction-args instruction))))
1540          (set label marker))))
1541    ;; Add labels used for exception handlers.
1542    (dolist (handler *handlers*)
1543      (set (handler-from handler) marker)
1544      (set (handler-to handler) marker)
1545      (set (handler-code handler) marker))
1546    ;; Remove labels that are not used as branch targets.
1547    (let ((tail code))
1548      (loop
1549        (when (null tail)
1550          (return))
1551        (let ((instruction (car tail)))
1552          (when (= (instruction-opcode instruction) 202) ; LABEL
1553            (let ((label (car (instruction-args instruction))))
1554              (unless (eq (symbol-value label) marker)
1555                (setf (car tail) nil)
1556                (setf changed t)))))
1557        (setf tail (cdr tail))))
1558    (when changed
1559      (setf *code* (delete nil code))
1560      t)))
1561
1562(defun optimize-2 ()
1563  (let* ((code (coerce *code* 'list))
1564         (tail code)
1565         (changed nil))
1566    (loop
1567      (when (null (cdr tail))
1568        (return))
1569      (let ((instruction (car tail))
1570            next-instruction)
1571        (when (and instruction
1572                   (= (instruction-opcode instruction) 167) ; GOTO
1573                   (setf next-instruction (cadr tail)))
1574          (cond ((and (= (instruction-opcode next-instruction) 202) ; LABEL
1575                      (eq (car (instruction-args instruction))
1576                          (car (instruction-args next-instruction))))
1577                 ;; GOTO next instruction: we don't need this one.
1578                 (setf (car tail) nil)
1579                 (setf changed t))
1580                ((= (instruction-opcode next-instruction) 167) ; GOTO
1581                 ;; Two GOTOs in a row: the next instruction is unreachable.
1582                 (setf (cadr tail) nil)
1583                 (setf changed t)))))
1584      (setf tail (cdr tail)))
1585    (when changed
1586      (setf *code* (delete nil code))
1587      t)))
1588
1589;; CLEAR-VALUES CLEAR-VALUES => CLEAR-VALUES
1590;; GETSTATIC POP => nothing
1591(defun optimize-3 ()
1592  (let* ((code (coerce *code* 'list))
1593         (tail code)
1594         (changed nil))
1595    (loop
1596      (when (null (cdr tail))
1597        (return))
1598      (let ((this-opcode (instruction-opcode (car tail)))
1599            (next-opcode (instruction-opcode (cadr tail))))
1600        (case this-opcode
1601          (205 ; CLEAR-VALUES
1602           (when (eql next-opcode 205) ; CLEAR-VALUES
1603             (setf (car tail) (cadr tail)
1604                   (cdr tail) (cddr tail)
1605                   changed t)))
1606          (178 ; GETSTATIC
1607           (when (eql next-opcode 87) ; POP
1608             (setf (car tail) (caddr tail)
1609                   (cdr tail) (cdddr tail)
1610                   changed t)))))
1611      (setf tail (cdr tail)))
1612    (when changed
1613      (setf *code* code)
1614      t)))
1615
1616(defvar *delete-unreachable-code-flag* t)
1617
1618(defun delete-unreachable-code ()
1619  (when *delete-unreachable-code-flag*
1620    ;; Look for unreachable code after GOTO.
1621    (unless (listp *code*)
1622      (setf *code* (coerce *code* 'list)))
1623    (validate-labels *code*)
1624    (let* ((code *code*)
1625           (tail code)
1626           (locally-changed-p nil)
1627           (after-goto nil))
1628      (loop
1629        (when (null tail)
1630          (return))
1631        (let ((instruction (car tail)))
1632          (cond (after-goto
1633                 (if (= (instruction-opcode instruction) 202) ; LABEL
1634                     (setf after-goto nil)
1635                     ;; Unreachable.
1636                     (progn
1637                       (setf (car tail) nil)
1638                       (setf locally-changed-p t))))
1639                ((= (instruction-opcode instruction) 167) ; GOTO
1640                 (setf after-goto t))))
1641        (setf tail (cdr tail)))
1642      (when locally-changed-p
1643        (setf *code* (delete nil code))
1644        t))))
1645
1646(defvar *enable-optimization* t)
1647
1648(defun optimize-code ()
1649  (unless *enable-optimization*
1650    (%format t "optimizations are disabled~%"))
1651  (when *enable-optimization*
1652    (when *compiler-debug*
1653      (%format t "----- before optimization -----~%")
1654      (print-code))
1655    (loop
1656      (let ((changed-p nil))
1657        (setf changed-p (or (optimize-1) changed-p))
1658        (setf changed-p (or (optimize-2) changed-p))
1659        (setf changed-p (or (optimize-3) changed-p))
1660        (setf changed-p (or (delete-unreachable-code) changed-p))
1661        (unless changed-p
1662          (return))))
1663    (unless (typep *code* 'vector)
1664      (setf *code* (coerce *code* 'vector)))
1665    (when *compiler-debug*
1666      (%format t "----- after optimization -----~%")
1667      (print-code))))
1668
1669(defun code-bytes (code)
1670  (let ((length 0))
1671;;     (declare (type fixnum length))
1672    ;; Pass 1: calculate label offsets and overall length.
1673    (dotimes (i (length code))
1674      (declare (type fixnum i))
1675      (let* ((instruction (aref code i))
1676             (opcode (instruction-opcode instruction)))
1677        (if (= opcode 202) ; LABEL
1678            (let ((label (car (instruction-args instruction))))
1679              (set label length))
1680            (incf length (opcode-size opcode)))))
1681    ;; Pass 2: replace labels with calculated offsets.
1682    (let ((index 0))
1683;;       (declare (type fixnum index))
1684      (dotimes (i (length code))
1685        (declare (type fixnum i))
1686        (let ((instruction (aref code i)))
1687          (when (branch-opcode-p (instruction-opcode instruction))
1688            (let* ((label (car (instruction-args instruction)))
1689                   (offset (- (symbol-value `,label) index)))
1690              (setf (instruction-args instruction) (u2 offset))))
1691          (unless (= (instruction-opcode instruction) 202) ; LABEL
1692            (incf index (opcode-size (instruction-opcode instruction)))))))
1693    ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
1694    (let ((bytes (make-array length))
1695          (index 0))
1696;;       (declare (type fixnum index))
1697      (dotimes (i (length code))
1698        (declare (type fixnum i))
1699        (let ((instruction (aref code i)))
1700          (unless (= (instruction-opcode instruction) 202) ; LABEL
1701            (setf (svref bytes index) (instruction-opcode instruction))
1702            (incf index)
1703            (dolist (byte (instruction-args instruction))
1704              (setf (svref bytes index) byte)
1705              (incf index)))))
1706      bytes)))
1707
1708(defsubst write-u1 (n stream)
1709  (declare (optimize speed))
1710  (sys::write-8-bits n stream))
1711
1712(defun write-u2 (n stream)
1713  (declare (optimize speed))
1714  (sys::write-8-bits (ash n -8) stream)
1715  (sys::write-8-bits (logand n #xFF) stream))
1716
1717(defun write-u4 (n stream)
1718  (declare (optimize speed))
1719  (write-u2 (ash n -16) stream)
1720  (write-u2 (logand n #xFFFF) stream))
1721
1722(defun write-s4 (n stream)
1723  (declare (optimize speed))
1724  (cond ((minusp n)
1725         (write-u4 (1+ (logxor (- n) #xFFFFFFFF)) stream))
1726        (t
1727         (write-u4 n stream))))
1728
1729(defun write-utf8 (string stream)
1730  (declare (optimize speed))
1731  (dotimes (i (length string))
1732    (declare (type fixnum i))
1733    (let ((c (schar string i)))
1734      (if (eql c #\null)
1735          (progn
1736            (sys::write-8-bits #xC0 stream)
1737            (sys::write-8-bits #x80 stream))
1738          (sys::write-8-bits (char-int c) stream)))))
1739
1740(defun utf8-length (string)
1741  (declare (optimize speed))
1742  (let ((length (length string)))
1743    (declare (type fixnum length))
1744    (dotimes (i length)
1745      (declare (type fixnum i))
1746      (when (eql (schar string i) #\null)
1747        (incf length)))
1748    length))
1749
1750(defun write-constant-pool-entry (entry stream)
1751  (declare (optimize speed))
1752  (let ((tag (first entry)))
1753    (write-u1 tag stream)
1754    (case tag
1755      (1 ; UTF8
1756       (write-u2 (utf8-length (third entry)) stream)
1757       (write-utf8 (third entry) stream))
1758      (3 ; int
1759       (write-s4 (second entry) stream))
1760      ((5 6)
1761       (write-u4 (second entry) stream)
1762       (write-u4 (third entry)) stream)
1763      ((9 10 11 12)
1764       (write-u2 (second entry) stream)
1765       (write-u2 (third entry) stream))
1766      ((7 8)
1767       (write-u2 (second entry) stream))
1768      (t
1769       (error "WRITE-CP-ENTRY unhandled tag ~D~%" tag)))))
1770
1771(defun write-constant-pool (stream)
1772  (declare (optimize speed))
1773  (write-u2 *pool-count* stream)
1774  (dolist (entry (reverse *pool*))
1775    (write-constant-pool-entry entry stream)))
1776
1777(defstruct field
1778  access-flags
1779  name
1780  descriptor
1781  name-index
1782  descriptor-index)
1783
1784(defstruct method
1785  access-flags
1786  name
1787  descriptor
1788  name-index
1789  descriptor-index
1790  max-stack
1791  max-locals
1792  code
1793  handlers)
1794
1795(defun make-constructor (super name args body)
1796  (let* ((*compiler-debug* nil) ; We don't normally need to see debugging output for constructors.
1797         (constructor (make-method :name "<init>"
1798                                   :descriptor "()V"))
1799         (*code* ())
1800         (*handlers* nil))
1801    (dformat t "make-constructor super = ~S~%" super)
1802    (setf (method-name-index constructor) (pool-name (method-name constructor)))
1803    (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor)))
1804    (setf (method-max-locals constructor) 1)
1805    (cond
1806     (*hairy-arglist-p*
1807      (emit 'aload_0) ;; this
1808      (emit 'aconst_null) ;; name
1809      (let* ((*print-level* nil)
1810             (*print-length* nil)
1811             (s (%format nil "~S" args)))
1812        (emit 'ldc
1813              (pool-string s))
1814        (emit-invokestatic +lisp-class+
1815                           "readObjectFromString"
1816                           "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
1817                           0))
1818      (emit-push-nil) ;; body
1819      (emit 'aconst_null) ;; environment
1820      (emit-invokespecial super
1821                          "<init>"
1822                          ;;                                "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/Environment;)V"
1823                          `((,+lisp-symbol+ ,+lisp-object+ ,+lisp-object+ ,+lisp-environment+) nil)
1824                          -5))
1825     (*child-p*
1826      (cond
1827       ((null *closure-variables*)
1828        (emit 'aload_0)
1829        (emit-invokespecial super
1830                            "<init>"
1831                            "()V"
1832                            -1))
1833        (t
1834         (emit 'aload_0) ;; this
1835         (let* ((*print-level* nil)
1836                (*print-length* nil)
1837                (s (%format nil "~S" args)))
1838           (emit 'ldc
1839                 (pool-string s))
1840           (emit-invokestatic +lisp-class+
1841                              "readObjectFromString"
1842                              "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
1843                              0))
1844         (emit-invokespecial super
1845                             "<init>"
1846                             "(Lorg/armedbear/lisp/LispObject;)V"
1847                             -2))))
1848     (t
1849      (emit 'aload_0)
1850      (emit-invokespecial super
1851                          "<init>"
1852                          "()V"
1853                          -1)))
1854    (setf *code* (append *static-code* *code*))
1855    (emit 'return)
1856    (finalize-code)
1857;;     (optimize-code)
1858    (setf *code* (resolve-instructions *code*))
1859    (setf (method-max-stack constructor) (analyze-stack))
1860    (setf (method-code constructor) (code-bytes *code*))
1861    (setf (method-handlers constructor) (nreverse *handlers*))
1862    constructor))
1863
1864(defun write-exception-table (method stream)
1865  (let ((handlers (method-handlers method)))
1866    (write-u2 (length handlers) stream) ; number of entries
1867    (dolist (handler handlers)
1868      (write-u2 (symbol-value (handler-from handler)) stream)
1869      (write-u2 (symbol-value (handler-to handler)) stream)
1870      (write-u2 (symbol-value (handler-code handler)) stream)
1871      (write-u2 (handler-catch-type handler) stream))))
1872
1873(defun write-code-attr (method stream)
1874  (declare (optimize speed))
1875  (let* ((name-index (pool-name "Code"))
1876         (code (method-code method))
1877         (code-length (length code))
1878         (length (+ code-length 12
1879                    (* (length (method-handlers method)) 8)))
1880         (max-stack (or (method-max-stack method) 20))
1881         (max-locals (or (method-max-locals method) 1)))
1882    (write-u2 name-index stream)
1883    (write-u4 length stream)
1884    (write-u2 max-stack stream)
1885    (write-u2 max-locals stream)
1886    (write-u4 code-length stream)
1887    (dotimes (i code-length)
1888      (declare (type fixnum i))
1889      (write-u1 (svref code i) stream))
1890    (write-exception-table method stream)
1891    (write-u2 0 stream) ; attributes count
1892    ))
1893
1894(defun write-method (method stream)
1895  (declare (optimize speed))
1896  (write-u2 (or (method-access-flags method) #x1) stream) ; access flags
1897  (write-u2 (method-name-index method) stream)
1898  (write-u2 (method-descriptor-index method) stream)
1899  (write-u2 1 stream) ; attributes count
1900  (write-code-attr method stream))
1901
1902(defun write-field (field stream)
1903  (declare (optimize speed))
1904  (write-u2 (or (field-access-flags field) #x1) stream) ; access flags
1905  (write-u2 (field-name-index field) stream)
1906  (write-u2 (field-descriptor-index field) stream)
1907  (write-u2 0 stream)) ; attributes count
1908
1909(defun declare-field (name descriptor)
1910  (let ((field (make-field :name name :descriptor descriptor)))
1911    (setf (field-access-flags field) (logior #x8 #x2)) ; private static
1912    (setf (field-name-index field) (pool-name (field-name field)))
1913    (setf (field-descriptor-index field) (pool-name (field-descriptor field)))
1914    (setq *fields* (cons field *fields*))))
1915
1916(defun sanitize (symbol)
1917  (declare (optimize speed))
1918  (let* ((input (symbol-name symbol))
1919         (output (make-array (length input) :fill-pointer 0 :element-type 'character)))
1920    (dotimes (i (length input))
1921      (declare (type fixnum i))
1922      (let ((c (char-upcase (char input i))))
1923        (cond ((<= #.(char-code #\A) (char-code c) #.(char-code #\Z))
1924               (vector-push c output))
1925              ((eql c #\-)
1926               (vector-push #\_ output)))))
1927    (when (plusp (length output))
1928      output)))
1929
1930(defvar *declared-symbols* nil)
1931(defvar *declared-functions* nil)
1932(defvar *declared-strings* nil)
1933(defvar *declared-fixnums* nil)
1934
1935(defun declare-symbol (symbol)
1936  (let ((g (gethash symbol *declared-symbols*)))
1937    (unless g
1938      (let ((*code* *static-code*)
1939            (s (sanitize symbol)))
1940        (setf g (symbol-name (gensym)))
1941        (when s
1942          (setf g (concatenate 'string g "_" s)))
1943        (declare-field g +lisp-symbol+)
1944        (emit 'ldc (pool-string (symbol-name symbol)))
1945        (emit 'ldc (pool-string (package-name (symbol-package symbol))))
1946        (emit-invokestatic +lisp-class+
1947                           "internInPackage"
1948                           "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
1949                           -1)
1950        (emit 'putstatic
1951              *this-class*
1952              g
1953              +lisp-symbol+)
1954        (setf *static-code* *code*)
1955        (setf (gethash symbol *declared-symbols*) g)))
1956    g))
1957
1958(defun declare-keyword (symbol)
1959  (let ((g (gethash symbol *declared-symbols*)))
1960    (unless g
1961      (let ((*code* *static-code*))
1962        (setf g (symbol-name (gensym)))
1963        (declare-field g +lisp-symbol+)
1964        (emit 'ldc (pool-string (symbol-name symbol)))
1965        (emit-invokestatic "org/armedbear/lisp/Keyword"
1966                           "internKeyword"
1967                           "(Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
1968                           0)
1969        (emit 'putstatic
1970              *this-class*
1971              g
1972              +lisp-symbol+)
1973        (setf *static-code* *code*)
1974        (setf (gethash symbol *declared-symbols*) g)))
1975    g))
1976
1977(defun declare-function (symbol)
1978  (let ((f (gethash symbol *declared-functions*)))
1979    (unless f
1980      (setf f (symbol-name (gensym)))
1981      (let ((s (sanitize symbol)))
1982        (when s
1983          (setf f (concatenate 'string f "_" s))))
1984      (let ((*code* *static-code*)
1985            (g (gethash symbol *declared-symbols*)))
1986        (cond (g
1987               (emit 'getstatic
1988                     *this-class*
1989                     g
1990                     +lisp-symbol+))
1991              (t
1992               (emit 'ldc (pool-string (symbol-name symbol)))
1993               (emit 'ldc (pool-string (package-name (symbol-package symbol))))
1994               (emit-invokestatic +lisp-class+
1995                                  "internInPackage"
1996                                  "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
1997                                  -1)))
1998        (declare-field f +lisp-object+)
1999        (emit-invokevirtual +lisp-symbol-class+
2000                            "getSymbolFunctionOrDie"
2001                            "()Lorg/armedbear/lisp/LispObject;"
2002                            0)
2003        (emit 'putstatic
2004              *this-class*
2005              f
2006              +lisp-object+)
2007        (setq *static-code* *code*)
2008        (setf (gethash symbol *declared-functions*) f)))
2009    f))
2010
2011(defun declare-setf-function (name)
2012  (let ((f (gethash name *declared-functions*)))
2013    (unless f
2014      (let ((symbol (cadr name)))
2015        (setf f (symbol-name (gensym)))
2016        (let ((s (sanitize symbol)))
2017          (when s
2018            (setf f (concatenate 'string f "_SETF_" s))))
2019        (let ((*code* *static-code*)
2020              (g (gethash symbol *declared-symbols*)))
2021          (cond (g
2022                 (emit 'getstatic
2023                       *this-class*
2024                       g
2025                       +lisp-symbol+))
2026                (t
2027                 (emit 'ldc (pool-string (symbol-name symbol)))
2028                 (emit 'ldc (pool-string (package-name (symbol-package symbol))))
2029                 (emit-invokestatic +lisp-class+
2030                                    "internInPackage"
2031                                    "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
2032                                    -1)))
2033          (declare-field f +lisp-object+)
2034          (emit-invokevirtual +lisp-symbol-class+
2035                              "getSymbolSetfFunctionOrDie"
2036                              "()Lorg/armedbear/lisp/LispObject;"
2037                              0)
2038          (emit 'putstatic
2039                *this-class*
2040                f
2041                +lisp-object+)
2042          (setq *static-code* *code*)
2043          (setf (gethash name *declared-functions*) f))))
2044    f))
2045
2046(defun declare-fixnum (n)
2047  (declare (type fixnum n))
2048  (let ((g (gethash n *declared-fixnums*)))
2049    (unless g
2050      (let ((*code* *static-code*))
2051        (setf g (%format nil "FIXNUM_~A~D"
2052                         (if (minusp n) "MINUS_" "")
2053                         (abs n)))
2054        (declare-field g +lisp-fixnum+)
2055        (emit 'new +lisp-fixnum-class+)
2056        (emit 'dup)
2057        (case n
2058          (-1
2059           (emit 'iconst_m1))
2060          (0
2061           (emit 'iconst_0))
2062          (1
2063           (emit 'iconst_1))
2064          (2
2065           (emit 'iconst_2))
2066          (3
2067           (emit 'iconst_3))
2068          (4
2069           (emit 'iconst_4))
2070          (5
2071           (emit 'iconst_5))
2072          (t
2073           (emit 'ldc (pool-int n))))
2074        (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)
2075        (emit 'putstatic *this-class* g +lisp-fixnum+)
2076        (setf *static-code* *code*)
2077        (setf (gethash n *declared-fixnums*) g)))
2078    g))
2079
2080(defun declare-object-as-string (obj)
2081  (let* ((g (symbol-name (gensym)))
2082         (*print-level* nil)
2083         (*print-length* nil)
2084         (s (%format nil "~S" obj))
2085         (*code* *static-code*))
2086    (declare-field g +lisp-object+)
2087    (emit 'ldc
2088          (pool-string s))
2089    (emit-invokestatic +lisp-class+
2090                       "readObjectFromString"
2091                       "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
2092                       0)
2093    (emit 'putstatic
2094          *this-class*
2095          g
2096          +lisp-object+)
2097    (setf *static-code* *code*)
2098    g))
2099
2100(defun declare-package (obj)
2101  (let* ((g (symbol-name (gensym)))
2102         (*print-level* nil)
2103         (*print-length* nil)
2104         (s (%format nil "#.(FIND-PACKAGE ~S)" (package-name obj)))
2105         (*code* *static-code*))
2106    (declare-field g +lisp-object+)
2107    (emit 'ldc
2108          (pool-string s))
2109    (emit-invokestatic +lisp-class+
2110                       "readObjectFromString"
2111                       "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
2112                       0)
2113    (emit 'putstatic
2114          *this-class*
2115          g
2116          +lisp-object+)
2117    (setf *static-code* *code*)
2118    g))
2119
2120(defun declare-object (obj)
2121  (let ((key (symbol-name (gensym))))
2122    (sys::remember key obj)
2123    (let* ((g1 (declare-string key))
2124           (g2 (symbol-name (gensym)))
2125           (*code* *static-code*))
2126      (declare-field g2 +lisp-object+)
2127      (emit 'getstatic
2128            *this-class*
2129            g1
2130            +lisp-string+)
2131;;       (emit 'dup)
2132      (emit-invokestatic +lisp-class+
2133                         "recall"
2134                         "(Lorg/armedbear/lisp/SimpleString;)Lorg/armedbear/lisp/LispObject;"
2135                         0)
2136      (emit 'putstatic
2137            *this-class*
2138            g2
2139            +lisp-object+)
2140;;       (emit-invokestatic +lisp-class+
2141;;                          "forget"
2142;;                          "(Lorg/armedbear/lisp/SimpleString;)V"
2143;;                          -1)
2144      (setf *static-code* *code*)
2145      g2)))
2146
2147(defun declare-lambda (obj)
2148  (let* ((g (symbol-name (gensym)))
2149         (*print-level* nil)
2150         (*print-length* nil)
2151         (s (%format nil "~S" obj))
2152         (*code* *static-code*))
2153    (declare-field g +lisp-object+)
2154    (emit 'ldc
2155          (pool-string s))
2156    (emit-invokestatic +lisp-class+
2157                       "readObjectFromString"
2158                       "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
2159                       0)
2160    (emit-invokestatic +lisp-class+
2161                       "coerceToFunction"
2162                       "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2163                       0)
2164    (emit 'putstatic
2165          *this-class*
2166          g
2167          +lisp-object+)
2168    (setf *static-code* *code*)
2169    g))
2170
2171(defun declare-local-function (local-function)
2172  (let* ((g (symbol-name (gensym)))
2173         (classfile (local-function-classfile local-function))
2174         (*code* *static-code*))
2175    (declare-field g +lisp-object+)
2176    (emit 'ldc
2177          (pool-string (file-namestring classfile)))
2178    (emit-invokestatic +lisp-class+
2179                       "loadCompiledFunction"
2180                       "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
2181                       0)
2182    (emit 'putstatic
2183          *this-class*
2184          g
2185          +lisp-object+)
2186    (setf *static-code* *code*)
2187    g))
2188
2189(defun declare-string (string)
2190  (let ((g (gethash string *declared-strings*)))
2191    (unless g
2192      (let ((*code* *static-code*))
2193        (setf g (symbol-name (gensym)))
2194        (declare-field g +lisp-simple-string+)
2195        (emit 'new +lisp-simple-string-class+)
2196        (emit 'dup)
2197        (emit 'ldc (pool-string string))
2198        (emit-invokespecial +lisp-simple-string-class+
2199                            "<init>"
2200                            "(Ljava/lang/String;)V"
2201                            -2)
2202        (emit 'putstatic
2203              *this-class*
2204              g
2205              +lisp-simple-string+)
2206        (setf *static-code* *code*)
2207        (setf (gethash string *declared-strings*) g)))
2208    g))
2209
2210(defun compile-constant (form &key (target *val*) representation)
2211  (unless target
2212    (return-from compile-constant))
2213  (when (eq representation :unboxed-fixnum)
2214    (cond
2215     ((fixnump form)
2216      (emit-push-constant-int form)
2217      (emit-move-from-stack target)
2218      (return-from compile-constant))
2219     (t
2220      (assert nil))))
2221  (cond ((numberp form)
2222         (if (fixnump form)
2223             (let* ((n form)
2224                    (translations '(( 0 . "ZERO")
2225                                    ( 1 . "ONE")
2226                                    ( 2 . "TWO")
2227                                    ( 3 . "THREE")
2228                                    (-1 . "MINUS_ONE")))
2229                    (translation (cdr (assoc n translations))))
2230               (if translation
2231                   (emit 'getstatic
2232                         +lisp-fixnum-class+
2233                         translation
2234                         +lisp-fixnum+)
2235                   (emit 'getstatic
2236                         *this-class*
2237                         (declare-fixnum n)
2238                         +lisp-fixnum+)))
2239             (emit 'getstatic
2240                   *this-class*
2241                   (declare-object-as-string form)
2242                   +lisp-object+)))
2243        ((stringp form)
2244         (if *compile-file-truename*
2245             (emit 'getstatic
2246                   *this-class*
2247                   (declare-string form)
2248                   +lisp-simple-string+)
2249             (emit 'getstatic
2250                   *this-class*
2251                   (declare-object form)
2252                   +lisp-object+)))
2253        ((vectorp form)
2254         (if *compile-file-truename*
2255             (emit 'getstatic
2256                   *this-class*
2257                   (declare-object-as-string form)
2258                   +lisp-object+)
2259             (emit 'getstatic
2260                   *this-class*
2261                   (declare-object form)
2262                   +lisp-object+)))
2263        ((characterp form)
2264         (emit 'getstatic
2265               *this-class*
2266               (declare-object-as-string form)
2267               +lisp-object+))
2268        ((or (classp form) (hash-table-p form) (typep form 'generic-function))
2269         (emit 'getstatic
2270               *this-class*
2271               (declare-object form)
2272               +lisp-object+))
2273        ((pathnamep form)
2274         (let ((g (if *compile-file-truename*
2275                      (declare-object-as-string form)
2276                      (declare-object form))))
2277           (emit 'getstatic
2278                 *this-class*
2279                 g
2280                 +lisp-object+)))
2281        ((packagep form)
2282         (let ((g (if *compile-file-truename*
2283                      (declare-package form)
2284                      (declare-object form))))
2285           (emit 'getstatic
2286                 *this-class*
2287                 g
2288                 +lisp-object+)))
2289        (t
2290         (if *compile-file-truename*
2291             (error "COMPILE-CONSTANT unhandled case ~S" form)
2292             (emit 'getstatic
2293                   *this-class*
2294                   (declare-object form)
2295                   +lisp-object+))))
2296  (emit-move-from-stack target))
2297
2298(defparameter unary-operators (make-hash-table :test 'eq))
2299
2300(defun define-unary-operator (operator translation)
2301  (setf (gethash operator unary-operators) translation))
2302
2303(define-unary-operator '1+              "incr")
2304(define-unary-operator '1-              "decr")
2305(define-unary-operator 'ABS             "ABS")
2306(define-unary-operator 'ATOM            "ATOM")
2307(define-unary-operator 'BIT-VECTOR-P    "BIT_VECTOR_P")
2308(define-unary-operator 'CADR            "cadr")
2309(define-unary-operator 'CAR             "car")
2310(define-unary-operator 'CDDR            "cddr")
2311(define-unary-operator 'CDR             "cdr")
2312(define-unary-operator 'CHARACTERP      "CHARACTERP")
2313(define-unary-operator 'CLASS-OF        "classOf")
2314(define-unary-operator 'COMPLEXP        "COMPLEXP")
2315(define-unary-operator 'CONSTANTP       "CONSTANTP")
2316(define-unary-operator 'DENOMINATOR     "DENOMINATOR")
2317(define-unary-operator 'ENDP            "ENDP")
2318(define-unary-operator 'EVENP           "EVENP")
2319(define-unary-operator 'FIRST           "car")
2320(define-unary-operator 'FLOATP          "FLOATP")
2321(define-unary-operator 'INTEGERP        "INTEGERP")
2322(define-unary-operator 'LENGTH          "LENGTH")
2323(define-unary-operator 'LISTP           "LISTP")
2324(define-unary-operator 'MINUSP          "MINUSP")
2325(define-unary-operator 'NREVERSE        "nreverse")
2326(define-unary-operator 'NUMBERP         "NUMBERP")
2327(define-unary-operator 'NUMERATOR       "NUMERATOR")
2328(define-unary-operator 'ODDP            "ODDP")
2329(define-unary-operator 'PLUSP           "PLUSP")
2330(define-unary-operator 'RATIONALP       "RATIONALP")
2331(define-unary-operator 'REALP           "REALP")
2332(define-unary-operator 'REST            "cdr")
2333(define-unary-operator 'SECOND          "cadr")
2334(define-unary-operator 'SIMPLE-STRING-P "SIMPLE_STRING_P")
2335(define-unary-operator 'STRING          "STRING")
2336(define-unary-operator 'STRINGP         "STRINGP")
2337(define-unary-operator 'SYMBOLP         "SYMBOLP")
2338(define-unary-operator 'VECTORP         "VECTORP")
2339(define-unary-operator 'ZEROP           "ZEROP")
2340
2341(defun compile-function-call-1 (fun args target representation)
2342  (let ((arg (first args)))
2343    (when (eq fun '1+)
2344      (return-from compile-function-call-1 (compile-plus (list '+ 1 arg)
2345                                                         :target target
2346                                                         :representation representation)))
2347    (let ((s (gethash fun unary-operators)))
2348      (cond (s
2349             (compile-form arg :target :stack)
2350             (maybe-emit-clear-values arg)
2351             (emit-invoke-method s target representation)
2352             t)
2353            ((eq fun 'LIST)
2354             (emit 'new +lisp-cons-class+)
2355             (emit 'dup)
2356             (compile-form arg :target :stack)
2357             (maybe-emit-clear-values arg)
2358             (emit-invokespecial +lisp-cons-class+
2359                                 "<init>"
2360                                 "(Lorg/armedbear/lisp/LispObject;)V"
2361                                 -2)
2362             (emit-move-from-stack target)
2363             t)
2364            (t
2365             nil)))))
2366
2367(defparameter binary-operators (make-hash-table :test 'eq))
2368
2369(defun define-binary-operator (operator translation)
2370  (setf (gethash operator binary-operators) translation))
2371
2372(define-binary-operator 'eql                 "EQL")
2373(define-binary-operator 'equal               "EQUAL")
2374(define-binary-operator '+                   "add")
2375(define-binary-operator '-                   "subtract")
2376(define-binary-operator '/                   "divideBy")
2377(define-binary-operator '*                   "multiplyBy")
2378(define-binary-operator '<                   "IS_LT")
2379(define-binary-operator '<=                  "IS_LE")
2380(define-binary-operator '>                   "IS_GT")
2381(define-binary-operator '>=                  "IS_GE")
2382(define-binary-operator ' =                  "IS_E")
2383(define-binary-operator '/=                  "IS_NE")
2384(define-binary-operator 'mod                 "MOD")
2385(define-binary-operator 'ash                 "ash")
2386(define-binary-operator 'logand              "logand")
2387(define-binary-operator 'aref                "AREF")
2388(define-binary-operator 'sys::simple-typep   "typep")
2389(define-binary-operator 'rplaca              "RPLACA")
2390(define-binary-operator 'rplacd              "RPLACD")
2391(define-binary-operator 'sys::%rplaca        "_RPLACA")
2392(define-binary-operator 'sys::%rplacd        "_RPLACD")
2393
2394(defun compile-binary-operation (op args target representation)
2395;;   (dformat t "compile-binary-operation op = ~S representation = ~S~%"
2396;;            op representation)
2397  (compile-form (first args) :target :stack)
2398  (compile-form (second args) :target :stack)
2399  (unless (and (single-valued-p (first args))
2400               (single-valued-p (second args)))
2401    (emit-clear-values))
2402  (emit-invokevirtual +lisp-object-class+
2403                      op
2404                      "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2405                      -1)
2406  (when (eq representation :unboxed-fixnum)
2407    (emit-unbox-fixnum))
2408  (emit-move-from-stack target))
2409
2410(defun compile-function-call-2 (op args target representation)
2411  (let ((translation (gethash op binary-operators))
2412        (first (first args))
2413        (second (second args)))
2414    (if translation
2415        (compile-binary-operation translation args target representation)
2416        (case op
2417          (EQ
2418           (compile-form first :target :stack)
2419           (compile-form second :target :stack)
2420           (unless (and (single-valued-p first)
2421                        (single-valued-p second))
2422             (emit-clear-values))
2423           (let ((label1 (gensym))
2424                 (label2 (gensym)))
2425             (emit 'if_acmpeq `,label1)
2426             (emit-push-nil)
2427             (emit 'goto `,label2)
2428             (emit 'label `,label1)
2429             (emit-push-t)
2430             (emit 'label `,label2))
2431           (emit-move-from-stack target)
2432           t)
2433          (LIST
2434           (compile-form first :target :stack)
2435           (compile-form second :target :stack)
2436           (unless (and (single-valued-p first)
2437                        (single-valued-p second))
2438             (emit-clear-values))
2439           (emit-invokestatic +lisp-class+
2440                              "list2"
2441                              "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;"
2442                              -1)
2443           (emit-move-from-stack target)
2444           t)
2445          (SYS::%STRUCTURE-REF
2446           (when (fixnump second)
2447             (compile-form first :target :stack)
2448             (maybe-emit-clear-values first)
2449             (emit 'sipush second)
2450             (emit-invokevirtual +lisp-object-class+
2451                                 "getSlotValue"
2452                                 "(I)Lorg/armedbear/lisp/LispObject;"
2453                                 -1)
2454             (when (eq representation :unboxed-fixnum)
2455               (emit-unbox-fixnum))
2456             (emit-move-from-stack target representation)
2457             t))
2458          (t
2459           nil)))))
2460
2461(defun fixnum-or-unboxed-variable-p (arg)
2462  (or (fixnump arg)
2463      (unboxed-fixnum-variable arg)))
2464
2465(defun emit-push-int (arg)
2466  (if (fixnump arg)
2467      (emit-push-constant-int arg)
2468      (let ((variable (unboxed-fixnum-variable arg)))
2469        (if variable
2470            (emit 'iload (variable-register variable))
2471            (aver nil)))))
2472
2473(defun p2-eql (form &key (target *val*) representation)
2474;;   (dformat t "p2-eql form = ~S~%" form)
2475  (unless (= (length form) 3)
2476    (error "Wrong number of arguments for EQL."))
2477  (let ((arg1 (second form))
2478        (arg2 (third form)))
2479;;     (dformat t "arg1 = ~S~%" arg1)
2480;;     (dformat t "arg2 = ~S~%" arg2)
2481    (cond
2482     ((and (fixnum-or-unboxed-variable-p arg1)
2483           (fixnum-or-unboxed-variable-p arg2))
2484;;       (dformat t "p2-eql case 1~%")
2485      (emit-push-int arg1)
2486      (emit-push-int arg2)
2487      (let ((label1 (gensym))
2488            (label2 (gensym)))
2489        (emit 'if_icmpeq `,label1)
2490        (emit-push-nil)
2491        (emit 'goto `,label2)
2492        (emit 'label `,label1)
2493        (emit-push-t)
2494        (emit 'label `,label2))
2495      (emit-move-from-stack target))
2496     ((fixnum-or-unboxed-variable-p arg1)
2497      (emit-push-int arg1)
2498      (compile-form arg2 :target :stack)
2499      (maybe-emit-clear-values arg2)
2500      (emit 'swap)
2501      (emit-invokevirtual +lisp-object-class+
2502                          "eql"
2503                          "(I)Z"
2504                          -1)
2505      (let ((label1 (gensym))
2506            (label2 (gensym)))
2507        (emit 'ifne `,label1)
2508        (emit-push-nil)
2509        (emit 'goto `,label2)
2510        (emit 'label `,label1)
2511        (emit-push-t)
2512        (emit 'label `,label2))
2513      (emit-move-from-stack target))
2514     ((fixnum-or-unboxed-variable-p arg2)
2515      (compile-form arg1 :target :stack)
2516      (maybe-emit-clear-values arg1)
2517      (emit-push-int arg2)
2518      (emit-invokevirtual +lisp-object-class+
2519                          "eql"
2520                          "(I)Z"
2521                          -1)
2522      (let ((label1 (gensym))
2523            (label2 (gensym)))
2524        (emit 'ifne `,label1)
2525        (emit-push-nil)
2526        (emit 'goto `,label2)
2527        (emit 'label `,label1)
2528        (emit-push-t)
2529        (emit 'label `,label2))
2530      (emit-move-from-stack target))
2531     (t
2532;;       (dformat t "p2-eql case 3~%")
2533      (compile-form arg1 :target :stack)
2534      (compile-form arg2 :target :stack)
2535      (unless (and (single-valued-p arg1)
2536                   (single-valued-p arg2))
2537        (emit-clear-values))
2538      (emit-invokevirtual +lisp-object-class+
2539                          "EQL"
2540                          "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2541                          -1)
2542      (emit-move-from-stack target))))
2543  )
2544
2545(defun compile-function-call-3 (op args target)
2546  (case op
2547    (LIST
2548     (compile-form (first args) :target :stack)
2549     (compile-form (second args) :target :stack)
2550     (compile-form (third args) :target :stack)
2551     (unless (every 'single-valued-p args)
2552       (emit-clear-values))
2553     (emit-invokestatic +lisp-class+
2554                        "list3"
2555                        "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;"
2556                        -2)
2557     (emit-move-from-stack target)
2558     t)
2559    (SYS::%STRUCTURE-SET
2560     (when (fixnump (second args))
2561       (compile-form (first args) :target :stack)
2562       (maybe-emit-clear-values (first args))
2563       (emit 'sipush (second args))
2564       (compile-form (third args) :target :stack)
2565       (maybe-emit-clear-values (third args))
2566       (emit-invokevirtual +lisp-object-class+
2567                           "setSlotValue"
2568                           "(ILorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2569                           -2)
2570       (emit-move-from-stack target)
2571       t))
2572    (t
2573     nil)))
2574
2575(defvar *toplevel-defuns* nil)
2576
2577(defsubst notinline-p (name)
2578  (declare (optimize speed))
2579  (eq (get name '%inline) 'NOTINLINE))
2580
2581(defun inline-ok (name)
2582  (declare (optimize speed))
2583  (cond ((notinline-p name)
2584         nil)
2585        ((sys:built-in-function-p name)
2586         t)
2587        ((memq name *toplevel-defuns*)
2588         t)
2589        (t
2590         nil)))
2591
2592(defun unsafe-p (args)
2593  (cond ((node-p args)
2594         (unsafe-p (node-form args)))
2595        ((atom args)
2596         nil)
2597        (t
2598         (case (car args)
2599           (QUOTE
2600            nil)
2601           (LAMBDA
2602            nil)
2603           ((RETURN-FROM GO CATCH THROW UNWIND-PROTECT BLOCK)
2604            t)
2605           (t
2606            (dolist (arg args)
2607              (when (unsafe-p arg)
2608                (return t))))))))
2609
2610(defun rewrite-function-call (form)
2611  (let ((args (cdr form)))
2612    (if (unsafe-p args)
2613        (let ((syms ())
2614              (lets ()))
2615          ;; Preserve the order of evaluation of the arguments!
2616          (dolist (arg args)
2617            (if (constantp arg)
2618                (push arg syms)
2619                (let ((sym (gensym)))
2620                  (push sym syms)
2621                  (push (list sym arg) lets))))
2622          (list 'LET* (nreverse lets) (list* (car form) (nreverse syms))))
2623        form)))
2624
2625(defun process-args (args)
2626  (let ((numargs (length args)))
2627    (when (plusp numargs)
2628      (let ((must-clear-values nil))
2629        (cond ((<= numargs 4)
2630               (dolist (arg args)
2631                 (compile-form arg :target :stack)
2632                 (unless must-clear-values
2633                   (unless (single-valued-p arg)
2634                     (setf must-clear-values t)))))
2635              (t
2636               (emit 'sipush numargs)
2637               (emit 'anewarray "org/armedbear/lisp/LispObject")
2638               (let ((i 0))
2639                 (dolist (arg args)
2640                   (emit 'dup)
2641                   (emit 'sipush i)
2642                   (compile-form arg :target :stack)
2643                   (emit 'aastore) ; store value in array
2644                   (unless must-clear-values
2645                     (unless (single-valued-p arg)
2646                       (setf must-clear-values t)))
2647                   (incf i)))))
2648        (when must-clear-values
2649          (emit-clear-values))))))
2650
2651(defun emit-call-execute (numargs)
2652  (let ((descriptor
2653         (case numargs
2654           (0 "()Lorg/armedbear/lisp/LispObject;")
2655           (1 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2656           (2 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2657           (3 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2658           (4 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2659           (t "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")))
2660        (stack-effect (if (< numargs 5)
2661                          (- numargs)
2662                          -1)))
2663    (emit-invokevirtual +lisp-object-class+ "execute" descriptor stack-effect)))
2664
2665(defun emit-call-thread-execute (numargs)
2666  (let ((descriptor
2667         (case numargs
2668           (0 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2669           (1 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2670           (2 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2671           (3 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2672           (4 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")
2673           (t "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;")))
2674        (stack-effect (if (< numargs 5)
2675                          (- (1+ numargs))
2676                          -2)))
2677    (emit-invokevirtual +lisp-thread-class+ "execute" descriptor stack-effect)))
2678
2679(defun compile-function-call (form target representation)
2680  (let ((op (car form))
2681        (args (cdr form)))
2682    (unless (symbolp op)
2683      (error "COMPILE-FUNCTION-CALL ~S is not a symbol" op))
2684    (when (find-local-function op)
2685      (return-from compile-function-call (compile-local-function-call form target)))
2686    (let ((numargs (length args)))
2687      (case (length args)
2688        (1
2689         (when (compile-function-call-1 op args target representation)
2690           (return-from compile-function-call)))
2691        (2
2692         (when (compile-function-call-2 op args target representation)
2693           (return-from compile-function-call)))
2694        (3
2695         (when (compile-function-call-3 op args target)
2696           (return-from compile-function-call))))
2697      (unless (> *speed* *debug*)
2698        (emit-push-current-thread))
2699      (cond
2700       ((eq op (compiland-name *current-compiland*)) ; recursive call
2701        (emit 'aload 0)) ; this
2702       ((inline-ok op)
2703        (emit 'getstatic
2704              *this-class*
2705              (declare-function op)
2706              +lisp-object+))
2707       ((null (symbol-package op))
2708        (let ((g (if *compile-file-truename*
2709                     (declare-object-as-string op)
2710                     (declare-object op))))
2711          (emit 'getstatic
2712                *this-class*
2713                g
2714                +lisp-object+)))
2715       (t
2716        (emit 'getstatic
2717              *this-class*
2718              (declare-symbol op)
2719              +lisp-symbol+)))
2720      (process-args args)
2721      (if (> *speed* *debug*)
2722          (emit-call-execute numargs)
2723          (emit-call-thread-execute numargs))
2724      (when (eq representation :unboxed-fixnum)
2725        (emit-unbox-fixnum))
2726      (emit-move-from-stack target))))
2727
2728(defun compile-call (args)
2729  (let ((numargs (length args)))
2730    (cond ((> *speed* *debug*)
2731           (process-args args)
2732           (emit-call-execute numargs))
2733          (t
2734           (emit-push-current-thread)
2735           (emit 'swap) ; Stack: thread function
2736           (process-args args)
2737           (emit-call-thread-execute numargs)))))
2738
2739(define-source-transform funcall (&whole form fun &rest args)
2740  (cond ((> *debug* *speed*)
2741         form)
2742        ((and (consp fun)
2743              (eq (car fun) 'FUNCTION)
2744              (symbolp (cadr fun)))
2745         `(,(cadr fun) ,@args))
2746        ((and (consp fun)
2747              (eq (car fun) 'QUOTE))
2748         (let ((sym (cadr fun)))
2749           (if (and (symbolp sym)
2750                    (eq (symbol-package sym) (find-package "CL"))
2751                    (not (special-operator-p sym))
2752                    (not (macro-function sym)))
2753               `(,(cadr fun) ,@args)
2754               form)))
2755        (t
2756         form)))
2757
2758(defun compile-funcall (form &key (target *val*) representation)
2759  (unless (> (length form) 1)
2760    (compiler-style-warn "Wrong number of arguments for ~A." (car form))
2761    (compile-function-call form target representation))
2762  (when (> *debug* *speed*)
2763    (return-from compile-funcall (compile-function-call form target representation)))
2764  (compile-form (cadr form) :target :stack)
2765  (maybe-emit-clear-values (cadr form))
2766  (compile-call (cddr form))
2767  (emit-move-from-stack target))
2768
2769(defun compile-local-function-call (form target)
2770  (dformat t "compile-local-function-call~%")
2771  (let* ((op (car form))
2772         (args (cdr form))
2773         (local-function (find-local-function op)))
2774    (cond
2775     ((eq (local-function-compiland local-function) *current-compiland*)
2776      (emit 'aload_0))
2777     ((local-function-variable local-function)
2778      ;; LABELS
2779      (dformat t "compile-local-function-call LABELS case~%")
2780      (emit 'var-ref (local-function-variable local-function) :stack))
2781     (t
2782      (let* ((g (if *compile-file-truename*
2783                    (declare-local-function local-function)
2784                    (declare-object (local-function-function local-function)))))
2785        (emit 'getstatic
2786              *this-class*
2787              g
2788              +lisp-object+)))) ; Stack: template-function
2789
2790    (when *closure-variables*
2791      (emit 'checkcast +lisp-ctf-class+))
2792
2793    (when *closure-variables*
2794      ;; First arg is closure variable array.
2795      (aver (not (null (compiland-closure-register *current-compiland*))))
2796      (emit 'aload (compiland-closure-register *current-compiland*)))
2797    (cond
2798     ((> (length args) 4)
2799      (emit-push-constant-int (length args))
2800      (emit 'anewarray "org/armedbear/lisp/LispObject")
2801      (let ((i 0)
2802            (must-clear-values nil))
2803        (dolist (arg args)
2804          (emit 'dup)
2805          (emit 'sipush i)
2806          (compile-form arg :target :stack)
2807          (emit 'aastore) ; store value in array
2808          (unless must-clear-values
2809            (unless (single-valued-p arg)
2810              (setf must-clear-values t)))
2811          (incf i))
2812        (when must-clear-values
2813          (emit-clear-values)))) ; array left on stack here
2814     (t
2815      (let ((must-clear-values nil))
2816        (dolist (arg args)
2817          (compile-form arg :target :stack)
2818          (unless must-clear-values
2819            (unless (single-valued-p arg)
2820              (setf must-clear-values t))))
2821        (when must-clear-values
2822          (emit-clear-values))))) ; args left on stack here
2823
2824    (if *closure-variables*
2825          (case (length args)
2826            (0
2827             (emit-invokevirtual +lisp-ctf-class+
2828                                 "execute"
2829                                 "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2830                                 -1))
2831            (1
2832             (emit-invokevirtual +lisp-ctf-class+
2833                                 "execute"
2834                                 "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2835                                 -2))
2836            (2
2837             (emit-invokevirtual +lisp-ctf-class+
2838                                 "execute"
2839                                 "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2840                                 -3))
2841            (3
2842             (emit-invokevirtual +lisp-ctf-class+
2843                                 "execute"
2844                                 "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2845                                 -4))
2846            (4
2847             (emit-invokevirtual +lisp-ctf-class+
2848                                 "execute"
2849                                 "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2850                                 -5))
2851            (t
2852             (emit-invokevirtual +lisp-ctf-class+
2853                                 "execute"
2854                                 "([Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2855                                 -2)))
2856          ;; No closure variables.
2857          (case (length args)
2858            (0
2859             (emit-invokevirtual +lisp-object-class+
2860                                 "execute"
2861                                 "()Lorg/armedbear/lisp/LispObject;"
2862                                 0))
2863            (1
2864             (emit-invokevirtual +lisp-object-class+
2865                                 "execute"
2866                                 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2867                                 -1))
2868            (2
2869             (emit-invokevirtual +lisp-object-class+
2870                                 "execute"
2871                                 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2872                                 -2))
2873            (3
2874             (emit-invokevirtual +lisp-object-class+
2875                                 "execute"
2876                                 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2877                                 -3))
2878            (4
2879             (emit-invokevirtual +lisp-object-class+
2880                                 "execute"
2881                                 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2882                                 -4))
2883            (t
2884             (emit-invokevirtual +lisp-object-class+
2885                                 "execute"
2886                                 "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2887                                 -1))))
2888    (cond ((null target)
2889           (emit 'pop)
2890           (maybe-emit-clear-values form))
2891          ((eq target :stack))
2892          ((fixnump target)
2893           (emit 'astore target))
2894          (t
2895           (%format t "line 1876~%")
2896           (aver nil)))))
2897
2898(defparameter java-predicates (make-hash-table :test 'eq))
2899
2900(defun define-java-predicate (predicate translation)
2901  (setf (gethash predicate java-predicates) translation))
2902
2903(define-java-predicate 'CHARACTERP         "characterp")
2904(define-java-predicate 'CONSTANTP          "constantp")
2905(define-java-predicate 'ENDP               "endp")
2906(define-java-predicate 'EVENP              "evenp")
2907(define-java-predicate 'FLOATP             "floatp")
2908(define-java-predicate 'INTEGERP           "integerp")
2909(define-java-predicate 'LISTP              "listp")
2910(define-java-predicate 'MINUSP             "minusp")
2911(define-java-predicate 'NUMBERP            "numberp")
2912(define-java-predicate 'ODDP               "oddp")
2913(define-java-predicate 'PLUSP              "plusp")
2914(define-java-predicate 'RATIONALP          "rationalp")
2915(define-java-predicate 'REALP              "realp")
2916(define-java-predicate 'STRINGP            "stringp")
2917(define-java-predicate 'SPECIAL-VARIABLE-P "isSpecialVariable")
2918(define-java-predicate 'VECTORP            "vectorp")
2919(define-java-predicate 'ZEROP              "zerop")
2920
2921(defun compile-test-2 (form negatep)
2922  (let* ((op (car form))
2923         (args (cdr form))
2924         (arg (car args))
2925         variable)
2926    (when (memq op '(NOT NULL))
2927      (return-from compile-test-2 (compile-test arg (not negatep))))
2928    (when (setf variable (unboxed-fixnum-variable arg))
2929      (case op
2930        (MINUSP
2931         (dformat t "compile-test-2 minusp case~%")
2932         (aver (variable-register variable))
2933         (emit 'iload (variable-register variable))
2934         (return-from compile-test-2 (if negatep 'iflt 'ifge))
2935         )
2936        ))
2937    (when (eq op 'SYMBOLP)
2938      (process-args args)
2939      (emit 'instanceof +lisp-symbol-class+)
2940      (return-from compile-test-2 (if negatep 'ifne 'ifeq)))
2941    (when (eq op 'FIXNUMP)
2942      (process-args args)
2943      (emit 'instanceof +lisp-fixnum-class+)
2944      (return-from compile-test-2 (if negatep 'ifne 'ifeq)))
2945    (when (eq op 'CONSP)
2946      (process-args args)
2947      (emit 'instanceof +lisp-cons-class+)
2948      (return-from compile-test-2 (if negatep 'ifne 'ifeq)))
2949    (when (eq op 'ATOM)
2950      (process-args args)
2951      (emit 'instanceof +lisp-cons-class+)
2952      (return-from compile-test-2 (if negatep 'ifeq 'ifne)))
2953    (let ((s (gethash op java-predicates)))
2954      (when s
2955        (process-args args)
2956        (emit-invokevirtual +lisp-object-class+
2957                            s
2958                            "()Z"
2959                            0)
2960        (return-from compile-test-2 (if negatep 'ifne 'ifeq)))))
2961  ;; Otherwise...
2962  (compile-form form :target :stack)
2963  (maybe-emit-clear-values form)
2964  (emit-push-nil)
2965  (if negatep 'if_acmpne 'if_acmpeq))
2966
2967(defun p2-numeric-comparison (form &key (target *val*) representation)
2968  (let ((op (car form))
2969        (args (cdr form)))
2970    (case (length args)
2971      (2
2972       (let ((first (first args))
2973             (second (second args))
2974             var1 var2)
2975         (cond
2976          ((and (fixnump first) (fixnump second))
2977           (dformat t "p2-numeric-comparison form = ~S~%" form)
2978           (if (funcall op first second)
2979               (emit-push-t)
2980               (emit-push-nil))
2981           (return-from p2-numeric-comparison))
2982          ((fixnump second)
2983           (dformat t "p2-numeric-comparison form = ~S~%" form)
2984           (compile-form (car args) :target :stack)
2985           (unless (single-valued-p first)
2986             (emit-clear-values))
2987           (emit-push-constant-int second)
2988           (emit-invokevirtual +lisp-object-class+
2989                               (case op
2990                                 (<  "isLessThan")
2991                                 (<= "isLessThanOrEqualTo")
2992                                 (>  "isGreaterThan")
2993                                 (>= "isGreaterThanOrEqualTo")
2994                                 (=  "isEqualTo")
2995                                 (/= "isNotEqualTo"))
2996                               "(I)Z"
2997                               -1)
2998           ;; Java boolean on stack here
2999           (let ((LABEL1 (gensym))
3000                 (LABEL2 (gensym)))
3001             (emit 'ifeq LABEL1)
3002             (emit-push-t)
3003             (emit 'goto LABEL2)
3004             (label LABEL1)
3005             (emit-push-nil)
3006             (label LABEL2)
3007             (emit-move-from-stack target))
3008           (return-from p2-numeric-comparison))
3009          ((and (setf var1 (unboxed-fixnum-variable first))
3010                (setf var2 (unboxed-fixnum-variable second)))
3011           (dformat t "p2-numeric-comparison both unboxed var case form = ~S~%" form)
3012           (let ((LABEL1 (gensym))
3013                 (LABEL2 (gensym)))
3014           (emit 'iload (variable-register var1))
3015           (emit 'iload (variable-register var2))
3016           (emit (case op
3017                   (<  'if_icmpge)
3018                   (<= 'if_icmpgt)
3019                   (>  'if_icmple)
3020                   (>= 'if_icmplt)
3021                   (=  'if_icmpne)
3022                   (/= 'if_icmpeq))
3023                 LABEL1)
3024             (emit-push-t)
3025             (emit 'goto LABEL2)
3026             (label LABEL1)
3027             (emit-push-nil)
3028             (label LABEL2)
3029             (emit-move-from-stack target)
3030             (return-from p2-numeric-comparison))
3031           )
3032          ) ; cond
3033       ))))
3034  ;; Still here?
3035  (compile-function-call form target representation)
3036  )
3037
3038(defun compile-test-3 (form negatep)
3039;;   (dformat t "compile-test-3 form = ~S~%" form)
3040  (let ((op (car form))
3041        (args (cdr form)))
3042    (when (eq op 'EQ)
3043      (process-args args)
3044      (return-from compile-test-3 (if negatep 'if_acmpeq 'if_acmpne)))
3045    (let* ((arg1 (first args))
3046           (arg2 (second args))
3047           (var1 (unboxed-fixnum-variable arg1))
3048           (var2 (unboxed-fixnum-variable arg2)))
3049      (when (memq op '(< <= > >= = /=))
3050        (when (and (arg-is-fixnum-p arg1)
3051                   (arg-is-fixnum-p arg2))
3052          (emit-push-int arg1)
3053          (emit-push-int arg2)
3054          (case op
3055            (<
3056             (return-from compile-test-3 (if negatep 'if_icmplt 'if_icmpge)))
3057            (<=
3058             (return-from compile-test-3 (if negatep 'if_icmple 'if_icmpgt)))
3059            (>
3060             (return-from compile-test-3 (if negatep 'if_icmpgt 'if_icmple)))
3061            (>=
3062             (return-from compile-test-3 (if negatep 'if_icmpge 'if_icmplt)))
3063            (=
3064             (return-from compile-test-3 (if negatep 'if_icmpeq 'if_icmpne)))
3065            (/=
3066             (return-from compile-test-3 (if negatep 'if_icmpne 'if_icmpeq)))
3067            ))
3068
3069        ;; Otherwise...
3070        (when (arg-is-fixnum-p arg2)
3071          (compile-form arg1 :target :stack)
3072          (maybe-emit-clear-values arg1)
3073          (emit-push-int arg2)
3074          (emit-invokevirtual +lisp-object-class+
3075                              (case op
3076                                (<  "isLessThan")
3077                                (<= "isLessThanOrEqualTo")
3078                                (>  "isGreaterThan")
3079                                (>= "isGreaterThanOrEqualTo")
3080                                (=  "isEqualTo")
3081                                (/= "isNotEqualTo"))
3082                              "(I)Z"
3083                              -1)
3084          (return-from compile-test-3 (if negatep 'ifne 'ifeq))))
3085
3086      (when (eq op '<)
3087          (when var1
3088            (dformat t "compile-test-3 unboxed fixnum var1 comparison case~%")
3089            (aver (variable-register var1))
3090            (emit 'iload (variable-register var1))
3091            (compile-form arg2 :target :stack)
3092            (emit 'swap)
3093            (emit-invokevirtual +lisp-object-class+
3094                                "isGreaterThan"
3095                                "(I)Z"
3096                                -1)
3097            (return-from compile-test-3 (if negatep 'ifne 'ifeq)))))
3098
3099    (let ((s (cdr (assq op
3100                        '((=      . "isEqualTo")
3101                          (/=     . "isNotEqualTo")
3102                          (<      . "isLessThan")
3103                          (<=     . "isLessThanOrEqualTo")
3104                          (>      . "isGreaterThan")
3105                          (>=     . "isGreaterThanOrEqualTo")
3106                          (EQL    . "eql")
3107                          (EQUAL  . "equal")
3108                          (EQUALP . "equalp"))))))
3109      (when s
3110        (let ((first (first args))
3111              (second (second args))
3112              variable)
3113          (cond
3114           ((fixnump second)
3115            (compile-form first :target :stack)
3116            (maybe-emit-clear-values first)
3117            (emit-push-constant-int second)
3118            (emit-invokevirtual +lisp-object-class+ s "(I)Z" -1))
3119           ((setf variable (unboxed-fixnum-variable second))
3120            (compile-form first :target :stack)
3121            (maybe-emit-clear-values first)
3122            (aver (variable-register variable))
3123            (emit 'iload (variable-register variable))
3124            (emit-invokevirtual +lisp-object-class+ s "(I)Z" -1))
3125           (t
3126            (process-args args)
3127            (emit-invokevirtual +lisp-object-class+
3128                                s
3129                                "(Lorg/armedbear/lisp/LispObject;)Z"
3130                                -1)))
3131          (return-from compile-test-3 (if negatep 'ifne 'ifeq))))))
3132
3133  ;; Otherwise...
3134  (compile-form form :target :stack)
3135  (maybe-emit-clear-values form)
3136  (emit-push-nil)
3137  (if negatep 'if_acmpne 'if_acmpeq))
3138
3139(defun compile-test (form negatep)
3140  ;; Use a Java boolean if possible.
3141  (when (and (consp form)
3142             (not (special-operator-p (car form))))
3143    (case (length form)
3144      (2
3145       (return-from compile-test (compile-test-2 form negatep)))
3146      (3
3147       (return-from compile-test (compile-test-3 form negatep)))))
3148  ;; Otherwise...
3149  (compile-form form :target :stack)
3150  (maybe-emit-clear-values form)
3151  (emit-push-nil)
3152  (if negatep 'if_acmpne 'if_acmpeq))
3153
3154(defun compile-if (form &key (target *val*) representation)
3155;;   (dformat t "compile-if form = ~S~%" form)
3156  (let* ((test (second form))
3157         (consequent (third form))
3158         (alternate (fourth form))
3159         (LABEL1 (gensym))
3160         (LABEL2 (gensym)))
3161    (cond ((eq test t)
3162           (compile-form consequent :target target :representation representation))
3163          ((null test)
3164           (compile-form alternate :target target :representation representation))
3165          ((numberp test)
3166           (compile-form consequent :target target :representation representation))
3167          (t
3168           (emit (compile-test test nil) LABEL1)
3169           (compile-form consequent :target target)
3170           (emit 'goto LABEL2)
3171           (label LABEL1)
3172           (compile-form alternate :target target)
3173           (label LABEL2)))))
3174
3175(defun compile-multiple-value-list (form &key (target *val*) representation)
3176  ;; Added Dec 9 2004 7:52 PM
3177  (emit-clear-values)
3178
3179  (compile-form (second form) :target :stack)
3180  (emit-invokestatic +lisp-class+
3181                     "multipleValueList"
3182                     "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
3183                     0)
3184  (emit-move-from-stack target))
3185
3186(defun compile-multiple-value-prog1 (form &key (target *val*) representation)
3187  (let ((first-subform (cadr form))
3188        (subforms (cddr form))
3189        (result-register (allocate-register))
3190        (values-register (allocate-register)))
3191
3192    ;; Added Dec 9 2004 3:46 AM
3193    ;; Make sure there are no leftover values from previous calls.
3194    (emit-clear-values)
3195
3196    (compile-form first-subform :target result-register)
3197    ;; Save multiple values returned by first subform.
3198    (emit-push-current-thread)
3199    (emit 'getfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;")
3200    (emit 'astore values-register)
3201    (dolist (subform subforms)
3202      (compile-form subform :target nil))
3203    ;; Restore multiple values returned by first subform.
3204    (emit-push-current-thread)
3205    (emit 'aload values-register)
3206    (emit 'putfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;")
3207    ;; Result.
3208    (emit 'aload result-register)
3209    (emit-move-from-stack target)))
3210
3211(defun compile-multiple-value-call (form &key (target *val*) representation)
3212  (case (length form)
3213    (1
3214     (error "Wrong number of arguments for MULTIPLE-VALUE-CALL."))
3215    (2
3216     (compile-form (second form) :target :stack)
3217     (emit-invokestatic +lisp-class+
3218                        "coerceToFunction"
3219                        "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
3220                        0)
3221     (emit-invokevirtual +lisp-object-class+
3222                         "execute"
3223                         "()Lorg/armedbear/lisp/LispObject;"
3224                         0)
3225     (emit-move-from-stack target))
3226    (3
3227     (let* ((*register* *register*)
3228            (function-register (allocate-register)))
3229       (compile-form (second form) :target function-register)
3230       (compile-form (third form) :target :stack)
3231       (emit 'aload function-register)
3232       (emit-push-current-thread)
3233       (emit-invokestatic +lisp-class+
3234                          "multipleValueCall1"
3235                          "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispThread;)Lorg/armedbear/lisp/LispObject;"
3236                          -2)
3237       (emit-move-from-stack target)))
3238    (t
3239     ;; The general case.
3240     (let* ((*register* *register*)
3241            (function-register (allocate-register))
3242            (values-register (allocate-register)))
3243       (compile-form (second form) :target :stack)
3244       (emit-invokestatic +lisp-class+
3245                          "coerceToFunction"
3246                          "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
3247                          0)
3248       (emit-move-from-stack function-register)
3249       (emit 'aconst_null)
3250       (emit 'astore values-register)
3251       (dolist (values-form (cddr form))
3252         (compile-form values-form :target :stack)
3253         (emit-push-current-thread)
3254         (emit 'swap)
3255         (emit 'aload values-register)
3256         (emit-invokevirtual +lisp-thread-class+
3257                             "accumulateValues"
3258                             "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)[Lorg/armedbear/lisp/LispObject;"
3259                             -2)
3260         (emit 'astore values-register)
3261         (maybe-emit-clear-values values-form))
3262       (emit 'aload function-register)
3263       (emit 'aload values-register)
3264       (emit-invokevirtual +lisp-object-class+
3265                           "execute"
3266                           "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
3267                           -1)
3268       (emit-move-from-stack target)))))
3269
3270;; Generates code to bind variable to value at top of runtime stack.
3271(defun compile-binding (variable)
3272  (cond ((variable-register variable)
3273         (emit 'astore (variable-register variable)))
3274        ((variable-special-p variable)
3275         (emit-push-current-thread)
3276         (emit 'swap)
3277         (emit 'getstatic
3278               *this-class*
3279               (declare-symbol (variable-name variable))
3280               +lisp-symbol+)
3281         (emit 'swap)
3282         (emit-invokevirtual +lisp-thread-class+
3283                             "bindSpecial"
3284                             "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V"
3285                             -3))
3286        ((variable-closure-index variable)
3287         (emit 'aload (compiland-closure-register *current-compiland*))
3288         (emit 'swap) ; array value
3289         (emit-push-constant-int (variable-closure-index variable))
3290         (emit 'swap) ; array index value
3291         (emit 'aastore))
3292        (t
3293         (aver nil))))
3294
3295(defun p2-m-v-b-node (block target)
3296  (let* ((*blocks* (cons block *blocks*))
3297         (*register* *register*)
3298         (form (block-form block))
3299         (*visible-variables* *visible-variables*)
3300         (specials ())
3301         (vars (second form))
3302         (bind-special-p nil)
3303         (variables (block-vars block)))
3304    (dolist (variable variables)
3305      (let ((special-p (variable-special-p variable)))
3306        (cond (special-p
3307               (setf bind-special-p t))
3308              (t
3309;;                (setf (variable-index variable) (length (context-vars *context*)))
3310               (unless (variable-closure-index variable)
3311                 (setf (variable-register variable) (allocate-register)))
3312;;                (add-variable-to-context variable)
3313               ))))
3314    ;; If we're going to bind any special variables...
3315    (when bind-special-p
3316      ;; Save current dynamic environment.
3317      (setf (block-environment-register block) (allocate-register))
3318      (emit-push-current-thread)
3319      (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)
3320      (emit 'astore (block-environment-register block)))
3321
3322    ;; Added Dec 9 2004 3:46 AM
3323    ;; Make sure there are no leftover values from previous calls.
3324    (emit-clear-values)
3325
3326    ;; Bind the variables.
3327    (aver (= (length vars) (length variables)))
3328    (cond ((= (length vars) 1)
3329           (compile-form (third form) :target :stack)
3330           (maybe-emit-clear-values (third form))
3331           (compile-binding (car variables)))
3332          (t
3333           (let* ((*register* *register*)
3334                  (result-register (allocate-register))
3335                  (values-register (allocate-register))
3336                  (LABEL1 (gensym))
3337                  (LABEL2 (gensym)))
3338             ;; Store primary value from values form in result register.
3339             (compile-form (third form) :target result-register)
3340             ;; Store values from values form in values register.
3341             (emit-push-current-thread)
3342             (emit 'getfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;")
3343             (emit-move-from-stack values-register)
3344             ;; Did we get just one value?
3345             (emit 'aload values-register)
3346             (emit 'ifnull LABEL1)
3347             ;; Reaching here, we have multiple values (or no values at all). We need
3348             ;; the slow path if we have more variables than values.
3349             (emit 'aload values-register)
3350             (emit 'arraylength)
3351             (emit 'bipush (length vars))
3352             (emit 'if_icmplt LABEL1)
3353             ;; Reaching here, we have enough values for all the variables. We can use
3354             ;; the values we have. This is the fast path.
3355             (emit 'aload values-register)
3356             (emit 'goto LABEL2)
3357             (label LABEL1)
3358             (emit-push-current-thread)
3359             (emit 'aload result-register)
3360             (emit 'bipush (length vars))
3361             (emit-invokevirtual +lisp-thread-class+
3362                                 "getValues"
3363                                 "(Lorg/armedbear/lisp/LispObject;I)[Lorg/armedbear/lisp/LispObject;"
3364                                 -2)
3365             ;; Values array is now on the stack at runtime.
3366             (label LABEL2)
3367             (let ((index 0))
3368               (dolist (variable variables)
3369                 (when (< index (1- (length vars)))
3370                   (emit 'dup))
3371                 (emit 'bipush index)
3372                 (incf index)
3373                 (emit 'aaload)
3374                 ;; Value is on the runtime stack at this point.
3375                 (compile-binding variable)))
3376             (maybe-emit-clear-values (third form)))))
3377    ;; Make the variables visible for the body forms.
3378    (dolist (variable variables)
3379      (push variable *visible-variables*)
3380;;       (push variable *all-variables*)
3381      )
3382    ;; Body.
3383    (compile-progn-body (cdddr form) target)
3384    (when bind-special-p
3385      ;; Restore dynamic environment.
3386      (emit 'aload *thread*)
3387      (emit 'aload (block-environment-register block))
3388      (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+))))
3389
3390(defun p2-let/let*-node (block target)
3391  (let* ((*blocks* (cons block *blocks*))
3392         (*register* *register*)
3393         (form (block-form block))
3394         (*visible-variables* *visible-variables*)
3395         (specialp nil))
3396    ;; Are we going to bind any special variables?
3397    (dolist (variable (block-vars block))
3398      (when (variable-special-p variable)
3399        (setf specialp t)
3400        (return)))
3401    ;; If so...
3402    (when specialp
3403      ;; Save current dynamic environment.
3404      (setf (block-environment-register block) (allocate-register))
3405      (emit-push-current-thread)
3406      (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)
3407      (emit 'astore (block-environment-register block)))
3408    (ecase (car form)
3409      (LET
3410       (p2-let-bindings block))
3411      (LET*
3412       (p2-let*-bindings block)))
3413    ;; Make declarations of free specials visible.
3414    (dolist (variable (block-free-specials block))
3415      (push variable *visible-variables*))
3416    ;; Body of LET/LET*.
3417    (compile-progn-body (cddr form) target)
3418    (when specialp
3419      ;; Restore dynamic environment.
3420      (emit 'aload *thread*)
3421      (emit 'aload (block-environment-register block))
3422      (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+))))
3423
3424(defun p2-let-bindings (block)
3425  (dolist (variable (block-vars block))
3426    (unless (variable-special-p variable)
3427      (unless (variable-closure-index variable)
3428        (setf (variable-register variable) (allocate-register)))))
3429  (let ((*register* *register*)
3430        (must-clear-values nil))
3431    ;; Evaluate each initform. If the variable being bound is special, allocate
3432    ;; a temporary register for the result; LET bindings must be done in
3433    ;; parallel, so we can't modify any specials until all the initforms have
3434    ;; been evaluated. Note that we can't just push the values on the stack
3435    ;; because we'll lose JVM stack consistency if there is a non-local
3436    ;; transfer of control from one of the initforms.
3437    (dolist (variable (block-vars block))
3438      (dformat t "variable = ~S writes = ~S~%" (variable-name variable) (variable-writes variable))
3439      (let ((initform (variable-initform variable)))
3440        (cond (initform
3441               (cond
3442                ((and *trust-user-type-declarations*
3443                      (variable-register variable)
3444                      (variable-declared-type variable)
3445                      (subtypep (variable-declared-type variable) 'FIXNUM))
3446                 (dformat t "p2-let-bindings declared fixnum case: ~S~%"
3447                          (variable-name variable))
3448                 (setf (variable-representation variable) :unboxed-fixnum)
3449                 (compile-form initform :target :stack :representation :unboxed-fixnum))
3450                ((and (variable-register variable)
3451                      (eql (variable-writes variable) 0)
3452                      (subtypep (derive-type initform) 'FIXNUM))
3453                 (dformat t "p2-let-bindings read-only fixnum case: ~S~%"
3454                          (variable-name variable))
3455                 (setf (variable-representation variable) :unboxed-fixnum)
3456                 (compile-form initform :target :stack :representation :unboxed-fixnum))
3457                (t
3458                 (compile-form initform :target :stack)))
3459               (unless must-clear-values
3460                 (unless (single-valued-p initform)
3461                   (setf must-clear-values t))))
3462              (t
3463               (emit-push-nil)))
3464        (cond
3465         ((variable-special-p variable)
3466          (emit-move-from-stack (setf (variable-temp-register variable) (allocate-register))))
3467         ((eq (variable-representation variable) :unboxed-fixnum)
3468          (emit 'istore (variable-register variable)))
3469         (t
3470          (compile-binding variable)))))
3471    (when must-clear-values
3472      (emit-clear-values))
3473    ;; Now that all the initforms have been evaluated, move the results from
3474    ;; the temporary registers (if any) to their proper destinations.
3475    (dolist (variable (block-vars block))
3476      (when (variable-temp-register variable)
3477        (aver (variable-special-p variable))
3478        (emit 'aload (variable-temp-register variable))
3479        (compile-binding variable))))
3480  ;; Now make the variables visible.
3481  (dolist (variable (block-vars block))
3482    (push variable *visible-variables*)))
3483
3484(defun p2-let*-bindings (block)
3485  (let ((must-clear-values nil))
3486    ;; Generate code to evaluate initforms and bind variables.
3487    (dolist (variable (block-vars block))
3488      (let* ((initform (variable-initform variable))
3489             (boundp nil))
3490        (cond
3491         ((and (variable-special-p variable)
3492               (eq initform (variable-name variable)))
3493          (emit-push-current-thread)
3494          (emit 'getstatic
3495                *this-class*
3496                (declare-symbol (variable-name variable))
3497                +lisp-symbol+)
3498          (emit-invokevirtual +lisp-thread-class+
3499                              "bindSpecialToCurrentValue"
3500                              "(Lorg/armedbear/lisp/Symbol;)V"
3501                              -2)
3502          (setf boundp t))
3503         (initform
3504          (cond
3505           ((and *trust-user-type-declarations*
3506;;                  (not *use-locals-vector*)
3507                 (null (variable-closure-index variable))
3508                 (not (variable-special-p variable))
3509                 (variable-declared-type variable)
3510                 (subtypep (variable-declared-type variable) 'FIXNUM))
3511            (dformat t "p2-let*-bindings declared fixnum case~%")
3512            (setf (variable-representation variable) :unboxed-fixnum)
3513            (compile-form initform :target :stack :representation :unboxed-fixnum)
3514            (setf (variable-register variable) (allocate-register))
3515            (emit 'istore (variable-register variable))
3516            (setf boundp t))
3517           ((and ;;(not *use-locals-vector*)
3518                 (null (variable-closure-index variable))
3519                 (not (variable-special-p variable))
3520                 (eql (variable-writes variable) 0)
3521                 (subtypep (derive-type initform) 'FIXNUM))
3522            (dformat t "p2-let*-bindings read-only fixnum case: ~S~%"
3523                     (variable-name variable))
3524            (setf (variable-representation variable) :unboxed-fixnum)
3525            (compile-form initform :target :stack :representation :unboxed-fixnum)
3526            (setf (variable-register variable) (allocate-register))
3527            (emit 'istore (variable-register variable))
3528            (setf boundp t))
3529           (t
3530            (compile-form initform :target :stack)))
3531          (unless must-clear-values
3532            (unless (single-valued-p initform)
3533              (setf must-clear-values t))))
3534         (t
3535          (emit-push-nil)))
3536        (unless (variable-special-p variable)
3537          (unless (or (variable-closure-index variable) (variable-register variable))
3538            (setf (variable-register variable) (allocate-register))))
3539        (push variable *visible-variables*)
3540        (unless boundp
3541          (compile-binding variable))))
3542    (when must-clear-values
3543      (emit-clear-values))))
3544
3545;; Returns list of declared specials.
3546(defun process-special-declarations (forms)
3547  (let ((specials ()))
3548    (dolist (form forms)
3549      (unless (and (consp form) (eq (car form) 'declare))
3550        (return))
3551      (let ((decls (cdr form)))
3552        (dolist (decl decls)
3553          (when (eq (car decl) 'special)
3554            (setf specials (append (cdr decl) specials))))))
3555    specials))
3556
3557(defun compile-locally (form &key (target *val*) representation)
3558  (let ((*visible-variables* *visible-variables*)
3559        (specials (process-special-declarations (cdr form))))
3560    (dolist (var specials)
3561      (push (make-variable :name var :special-p t) *visible-variables*))
3562    (cond ((null (cdr form))
3563           (when target
3564             (emit-push-nil)
3565             (emit-move-from-stack target)))
3566          (t
3567           (do ((forms (cdr form) (cdr forms)))
3568               ((null forms))
3569             (compile-form (car forms) :target (if (cdr forms) nil target)))))))
3570
3571(defun find-tag (name)
3572  (dolist (tag *visible-tags*)
3573    (when (eql name (tag-name tag))
3574      (return tag))))
3575
3576(defun p2-tagbody-node (block target)
3577  (let* ((*blocks* (cons block *blocks*))
3578         (*visible-tags* *visible-tags*)
3579         (*register* *register*)
3580         (form (block-form block))
3581         (body (cdr form))
3582         (local-tags ())
3583         (BEGIN-BLOCK (gensym))
3584         (END-BLOCK (gensym))
3585         (EXIT (gensym))
3586         environment-register
3587         (must-clear-values nil))
3588    ;; Scan for tags.
3589    (dolist (subform body)
3590      (when (or (symbolp subform) (integerp subform))
3591        (let* ((tag (make-tag :name subform :label (gensym) :block block)))
3592          (push tag local-tags)
3593          (push tag *visible-tags*))))
3594
3595    ;; FIXME Pass 1 doesn't detect all non-local GOs! (HANDLER-CASE.17)
3596    ;; So we do this unconditionally for now...
3597    (when (or t (block-non-local-go-p block))
3598      (setf environment-register (allocate-register))
3599      (emit-push-current-thread)
3600      (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)
3601      (emit 'astore environment-register))
3602
3603    (label BEGIN-BLOCK)
3604    (do* ((rest body (cdr rest))
3605          (subform (car rest) (car rest)))
3606         ((null rest))
3607      (cond ((or (symbolp subform) (integerp subform))
3608             (let ((tag (find-tag subform)))
3609               (unless tag
3610                 (error "COMPILE-TAGBODY: tag not found: ~S~%" subform))
3611               (label (tag-label tag))))
3612            (t
3613             (when (and (null (cdr rest)) ;; Last subform.
3614                        (consp subform)
3615                        (eq (car subform) 'GO))
3616               (maybe-generate-interrupt-check))
3617             (compile-form subform :target nil)
3618             (unless must-clear-values
3619               (unless (single-valued-p subform)
3620                 (setf must-clear-values t))))))
3621    (label END-BLOCK)
3622    (emit 'goto EXIT)
3623    (when (block-non-local-go-p block)
3624      ; We need a handler to catch non-local GOs.
3625      (let* ((HANDLER (gensym))
3626             (*register* *register*)
3627             (go-register (allocate-register))
3628             (tag-register (allocate-register)))
3629        (label HANDLER)
3630        ;; The Go object is on the runtime stack. Stack depth is 1.
3631        (emit 'dup)
3632        (emit 'astore go-register)
3633        ;; Get the tag.
3634        (emit 'checkcast +lisp-go-class+)
3635        (emit 'getfield +lisp-go-class+ "tag" +lisp-object+) ; Stack depth is still 1.
3636        (emit 'astore tag-register)
3637
3638        (dolist (tag local-tags)
3639          (let ((NEXT (gensym)))
3640            (emit 'aload tag-register)
3641            (emit 'getstatic
3642                  *this-class*
3643                  (if *compile-file-truename*
3644                      (declare-object-as-string (tag-label tag))
3645                      (declare-object (tag-label tag)))
3646                  +lisp-object+)
3647
3648            (emit 'if_acmpne NEXT) ;; Jump if not EQ.
3649            ;; Restore dynamic environment.
3650            (emit-push-current-thread)
3651            (aver (fixnump environment-register))
3652            (emit 'aload environment-register)
3653            (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)
3654            (emit 'goto (tag-label tag))
3655            (label NEXT)))
3656        ;; Not found. Re-throw Go.
3657        (emit 'aload go-register)
3658        (emit 'athrow)
3659
3660        ;; Finally...
3661        (push (make-handler :from BEGIN-BLOCK
3662                            :to END-BLOCK
3663                            :code HANDLER
3664                            :catch-type (pool-class +lisp-go-class+))
3665              *handlers*)))
3666    (label EXIT)
3667    (when must-clear-values
3668;;       (dformat t "p2-tagbody-node calling emit-clear-values~%")
3669      (emit-clear-values))
3670    ;; TAGBODY returns NIL.
3671    (when target
3672      (emit-push-nil)
3673      (emit-move-from-stack target))))
3674
3675(defun compile-go (form &key target representation)
3676  (let* ((name (cadr form))
3677         (tag (find-tag name)))
3678    (unless tag
3679      (error "COMPILE-GO: tag not found: ~S" name))
3680    (cond ((eq (tag-compiland tag) *current-compiland*)
3681           ;; Local case.
3682           (let ((tag-block (tag-block tag))
3683                 (register nil))
3684             ;; Does the GO leave an enclosing UNWIND-PROTECT?
3685             (let ((protected
3686                    (dolist (enclosing-block *blocks*)
3687                      (when (eq enclosing-block tag-block)
3688                        (return nil))
3689                      (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
3690                        (return t)))))
3691               (when protected
3692                 (error "COMPILE-GO: enclosing UNWIND-PROTECT")))
3693             (dolist (block *blocks*)
3694               (if (eq block tag-block)
3695                   (return)
3696                   (setf register (or (block-environment-register block) register))))
3697             (when register
3698               ;; Restore dynamic environment.
3699               (emit 'aload *thread*)
3700               (emit 'aload register)
3701               (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)))
3702           (maybe-generate-interrupt-check) ;; FIXME not exactly right, but better than nothing
3703           (emit 'goto (tag-label tag)))
3704          (t
3705           ;; Non-local GO.
3706           (emit 'new +lisp-go-class+)
3707           (emit 'dup)
3708           (compile-form `',(tag-label tag) :target :stack) ; Tag.
3709           (emit-invokespecial +lisp-go-class+
3710                               "<init>"
3711                               "(Lorg/armedbear/lisp/LispObject;)V"
3712                               -2)
3713           (emit 'athrow)
3714           ;; Following code will not be reached, but is needed for JVM stack
3715           ;; consistency.
3716           (when target
3717             (emit-push-nil)
3718             (emit-move-from-stack target))))))
3719
3720(defun compile-atom (form &key (target *val*) representation)
3721  (unless (= (length form) 2)
3722    (error "Wrong number of arguments for ATOM."))
3723  (compile-form (cadr form) :target :stack)
3724  (maybe-emit-clear-values (cadr form))
3725  (emit 'instanceof +lisp-cons-class+)
3726  (let ((LABEL1 (gensym))
3727        (LABEL2 (gensym)))
3728    (emit 'ifeq LABEL1)
3729    (emit-push-nil)
3730    (emit 'goto LABEL2)
3731    (label LABEL1)
3732    (emit-push-t)
3733    (label LABEL2)
3734    (emit-move-from-stack target)))
3735
3736(defun contains-return (form)
3737  (if (atom form)
3738      (if (node-p form)
3739          (contains-return (node-form form))
3740          nil)
3741      (case (car form)
3742        (QUOTE
3743         nil)
3744        (RETURN-FROM
3745         t)
3746        (t
3747         (dolist (subform form)
3748           (when (contains-return subform)
3749             (return t)))))))
3750
3751(defun compile-block (form &key (target *val*) representation)
3752;;   (format t "compile-block ~S~%" (cadr form))
3753  ;; This shouldn't be called, now that we have pass 1.
3754;;   (assert nil)
3755  (let ((block (make-block-node :form form
3756                                :name (cadr form)
3757                                :target target)))
3758    (compile-block-node block target)
3759  ))
3760
3761(defun compile-block-node (block target)
3762;;   (dformat t "COMPILE-BLOCK-NODE ~S block-return-p = ~S~%"
3763;;            (block-name block) (block-return-p block))
3764  (unless (block-node-p block)
3765    (%format t "type-of block = ~S~%" (type-of block))
3766    (aver (block-node-p block)))
3767  (let* ((*blocks* (cons block *blocks*))
3768         (*register* *register*))
3769    (setf (block-target block) target)
3770    (when (block-return-p block)
3771      ;; Save current dynamic environment.
3772      (setf (block-environment-register block) (allocate-register))
3773      (emit-push-current-thread)
3774      (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+)
3775      (emit 'astore (block-environment-register block)))
3776    (setf (block-catch-tag block) (gensym))
3777    (let* ((*register* *register*)
3778           (BEGIN-BLOCK (gensym))
3779           (END-BLOCK (gensym))
3780           (BLOCK-EXIT (block-exit block)))
3781      (label BEGIN-BLOCK) ; Start of protected range.
3782      ;; Implicit PROGN.
3783      (compile-progn-body (cddr (block-form block)) target)
3784      (label END-BLOCK) ; End of protected range.
3785      (emit 'goto BLOCK-EXIT) ; Jump over handler (if any).
3786      (when (block-non-local-return-p block)
3787        ; We need a handler to catch non-local RETURNs.
3788        (let ((HANDLER (gensym))
3789              (RETHROW (gensym)))
3790          (label HANDLER)
3791          ;; The Return object is on the runtime stack. Stack depth is 1.
3792          (emit 'dup) ; Stack depth is 2.
3793          (emit 'getfield +lisp-return-class+ "tag" +lisp-object+) ; Still 2.
3794          (compile-form `',(block-catch-tag block) :target :stack) ; Tag. Stack depth is 3.
3795          ;; If it's not the tag we're looking for...
3796          (emit 'if_acmpne RETHROW) ; Stack depth is 1.
3797          (emit 'getfield +lisp-return-class+ "result" +lisp-object+)
3798          (emit-move-from-stack target) ; Stack depth is 0.
3799          (emit 'goto BLOCK-EXIT)
3800          (label RETHROW)
3801          ;; Not the tag we're looking for.
3802          (emit 'athrow)
3803          ;; Finally...
3804          (push (make-handler :from BEGIN-BLOCK
3805                              :to END-BLOCK
3806                              :code HANDLER
3807                              :catch-type (pool-class +lisp-return-class+))
3808                *handlers*)))
3809      (label BLOCK-EXIT))
3810    (when (block-environment-register block)
3811      ;; We saved the dynamic environment above. Restore it now.
3812      (emit 'aload *thread*)
3813      (emit 'aload (block-environment-register block))
3814      (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+))))
3815
3816(defun compile-return-from (form &key (target *val*) representation)
3817  (let* ((name (second form))
3818         (result-form (third form))
3819         (block (find-block name)))
3820    (cond
3821     ((null block)
3822      (error "No block named ~S is currently visible." name))
3823     ((eq (block-compiland block) *current-compiland*)
3824      ;; Local case. Is the RETURN nested inside an UNWIND-PROTECT which
3825      ;; is inside the block we're returning from?
3826      (let ((protected
3827             (dolist (enclosing-block *blocks*)
3828               (when (eq enclosing-block block)
3829                 (return nil))
3830               (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
3831                 (return t)))))
3832        (when protected
3833          (error "COMPILE-RETURN-FROM: enclosing UNWIND-PROTECT")))
3834
3835      ;; Added Dec 9 2004 7:28 AM
3836;;       (dformat t "compile-return-from calling emit-clear-values~%")
3837      (emit-clear-values)
3838
3839      (compile-form result-form :target (block-target block))
3840      (emit 'goto (block-exit block)))
3841     (t
3842      ;; Non-local RETURN.
3843      (setf (block-non-local-return-p block) t)
3844      (let* ((*register* *register*)
3845             (temp-register (allocate-register)))
3846
3847        (emit-clear-values)
3848        (compile-form (third form) :target temp-register) ; Result.
3849
3850        (emit 'new +lisp-return-class+)
3851        (emit 'dup)
3852        (compile-form `',(block-catch-tag block) :target :stack) ; Tag.
3853
3854;        (emit-clear-values)
3855
3856;;         (compile-form (third form) :target :stack) ; Result.
3857        (emit 'aload temp-register)
3858
3859        (emit-invokespecial +lisp-return-class+
3860                            "<init>"
3861                            "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V"
3862                            -3)
3863        (emit 'athrow)
3864        ;; Following code will not be reached, but is needed for JVM stack
3865        ;; consistency.
3866        (when target
3867          (emit-push-nil)
3868          (emit-move-from-stack target)))))))
3869
3870(defun compile-cons (form &key (target *val*) representation)
3871  (unless (check-args form 2)
3872    (compile-function-call form target representation)
3873    (return-from compile-cons))
3874  (emit 'new +lisp-cons-class+)
3875  (emit 'dup)
3876  (process-args (cdr form))
3877  (emit-invokespecial "org/armedbear/lisp/Cons"
3878                      "<init>"
3879                      "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V"
3880                      -3)
3881  (emit-move-from-stack target))
3882
3883(defun compile-progn-body (body target)
3884  (cond ((null body)
3885         (when target
3886           (emit-push-nil)
3887           (emit-move-from-stack target)))
3888        (t
3889         (let ((must-clear-values nil))
3890           (do* ((forms body (cdr forms))
3891                 (form (car forms) (car forms)))
3892                ((null forms))
3893             (when (null (cdr forms))
3894               ;; Last form.
3895               (when must-clear-values
3896                 (emit-clear-values)))
3897             (compile-form form :target (if (cdr forms) nil target))
3898             (unless (null (cdr forms))
3899               (unless must-clear-values
3900                 (unless (single-valued-p form)
3901;;                    (dformat t "compile-progn-body not single-valued: ~S~%" form)
3902                   (setf must-clear-values t)))))))))
3903
3904(defun compile-progn (form &key (target *val*) representation)
3905  (compile-progn-body (cdr form) target)
3906  (when (eq representation :unboxed-fixnum)
3907    (emit-unbox-fixnum)))
3908
3909(defun compile-quote (form &key (target *val*) representation)
3910   (let ((obj (second form)))
3911     (cond ((null obj)
3912            (when target
3913              (emit-push-nil)
3914              (emit-move-from-stack target)))
3915           ((symbolp obj)
3916            (if (symbol-package obj)
3917                (let ((g (declare-symbol obj)))
3918                  (emit 'getstatic
3919                        *this-class*
3920                        g
3921                        +lisp-symbol+))
3922                ;; An uninterned symbol.
3923                (let ((g (if *compile-file-truename*
3924                             (declare-object-as-string obj)
3925                             (declare-object obj))))
3926                  (emit 'getstatic
3927                        *this-class*
3928                        g
3929                        +lisp-object+)))
3930            (emit-move-from-stack target))
3931           ((listp obj)
3932            (let ((g (if *compile-file-truename*
3933                         (declare-object-as-string obj)
3934                         (declare-object obj))))
3935              (emit 'getstatic
3936                    *this-class*
3937                    g
3938                    +lisp-object+)
3939              (emit-move-from-stack target)))
3940           ((constantp obj)
3941            (compile-constant obj :target target))
3942           (t
3943            (error "COMPILE-QUOTE: unsupported case: ~S" form)))))
3944
3945(defun compile-rplacd (form &key (target *val*) representation)
3946  (let ((args (cdr form)))
3947    (unless (= (length args) 2)
3948      (error "wrong number of arguments for RPLACD"))
3949    (compile-form (first args) :target :stack)
3950    (when target
3951      (emit 'dup))
3952    (compile-form (second args) :target :stack)
3953    (emit-invokevirtual +lisp-object-class+
3954                        "setCdr"
3955                        "(Lorg/armedbear/lisp/LispObject;)V"
3956                        -2)
3957    (when target
3958      (emit-move-from-stack target))))
3959
3960(defun compile-declare (form &key target representation)
3961  (when target
3962    (emit-push-nil)
3963    (emit-move-from-stack target)))
3964
3965(defun p2-local-function (compiland local-function)
3966  (let* ((name (compiland-name compiland))
3967         (arglist (cadr (compiland-lambda-expression compiland)))
3968         form
3969         function
3970         classfile)
3971    (when (or (memq '&optional arglist)
3972              (memq '&key arglist))
3973      (let ((state nil))
3974        (dolist (arg arglist)
3975          (cond ((memq arg lambda-list-keywords)
3976                 (setf state arg))
3977                ((memq state '(&optional &key))
3978                 (when (and (consp arg)
3979                            (not (constantp (second arg))))
3980                   (error "P2-LOCAL-FUNCTION: can't handle optional argument with non-constant initform.")))))))
3981    (setf form (compiland-lambda-expression compiland))
3982    (setf classfile (if *compile-file-truename*
3983                        (sys::next-classfile-name)
3984                        (prog1
3985                         (%format nil "local-~D.class" *child-count*)
3986                         (incf *child-count*))))
3987    (setf (compiland-classfile compiland) classfile)
3988    (let ((*current-compiland* compiland)
3989          (*speed* *speed*)
3990          (*safety* *safety*)
3991          (*debug* *debug*))
3992      (p2-compiland compiland))
3993    (cond (*compile-file-truename*
3994           ;; Verify that the class file is loadable.
3995           (unless (ignore-errors (sys:load-compiled-function classfile))
3996             (error "P2-LOCAL-FUNCTION: unable to load ~S." classfile)))
3997          (t
3998           (setf function (sys:load-compiled-function classfile))))
3999    (cond (local-function
4000           (setf (local-function-classfile local-function) classfile)
4001           (let ((g (if *compile-file-truename*
4002                        (declare-local-function local-function)
4003                        (declare-object function))))
4004             (emit 'getstatic
4005                   *this-class*
4006                   g
4007                   +lisp-object+)
4008             (emit 'var-set (local-function-variable local-function))))
4009          (t
4010           (push (make-local-function :name name
4011                                      :function function
4012                                      :classfile classfile)
4013                 *local-functions*)))))
4014
4015(defun p2-flet (form &key (target *val*) representation)
4016  (let ((*local-functions* *local-functions*)
4017        (compilands (cadr form))
4018        (body (cddr form)))
4019    (dolist (compiland compilands)
4020      (p2-local-function compiland nil))
4021    (do ((forms body (cdr forms)))
4022        ((null forms))
4023      (compile-form (car forms) :target (if (cdr forms) nil target)))))
4024
4025(defun p2-labels (form &key target representation)
4026  (let ((*local-functions* *local-functions*)
4027        (local-functions (cadr form))
4028        (body (cddr form)))
4029    (dolist (local-function local-functions)
4030      (push local-function *local-functions*)
4031      (push (local-function-variable local-function) *visible-variables*))
4032    (dolist (local-function local-functions)
4033      (let ((variable (local-function-variable local-function)))
4034        (aver (null (variable-register variable)))
4035        (unless (variable-closure-index variable)
4036          (setf (variable-register variable) (allocate-register)))
4037        (setf (variable-index variable) nil)))
4038    (dolist (local-function local-functions)
4039      (p2-local-function (local-function-compiland local-function) local-function))
4040    (do ((forms body (cdr forms)))
4041        ((null forms))
4042      (compile-form (car forms) :target (if (cdr forms) nil target)))))
4043
4044(defun contains-symbol (symbol form)
4045  (cond ((node-p form)
4046         (contains-symbol symbol (node-form form)))
4047        ((atom form)
4048         (eq form symbol))
4049        (t
4050         (or (contains-symbol symbol (car form))
4051             (contains-symbol symbol (cdr form))))))
4052
4053(defun contains-go (form)
4054  (cond ((node-p form)
4055         (contains-go (node-form form)))
4056        ((atom form)
4057         nil)
4058        (t
4059         (case (car form)
4060           (QUOTE
4061            nil)
4062           (GO
4063            t)
4064           (t
4065            (dolist (subform form)
4066              (when (contains-go subform)
4067                (return t))))))))
4068
4069(defun p2-lambda (compiland target)
4070  (let* ((lambda-list (cadr (compiland-lambda-expression compiland))))
4071    (when (or (memq '&optional lambda-list)
4072              (memq '&key lambda-list))
4073      (let ((state nil))
4074        (dolist (arg lambda-list)
4075          (cond ((memq arg lambda-list-keywords)
4076                 (setf state arg))
4077                ((memq state '(&optional &key))
4078                 (when (and (consp arg)
4079                            (not (constantp (second arg))))
4080                   (error "P2-LAMBDA: can't handle optional argument with non-constant initform.")))))))
4081    (cond (*compile-file-truename*
4082
4083           (setf (compiland-classfile compiland) (sys::next-classfile-name))
4084
4085           (let ((*current-compiland* compiland)
4086                 (*speed* *speed*)
4087                 (*safety* *safety*)
4088                 (*debug* *debug*)
4089                 compiled-function)
4090             (p2-compiland compiland))
4091
4092           (let* ((local-function (make-local-function :classfile (compiland-classfile compiland)))
4093                  (g (declare-local-function local-function)))
4094             (emit 'getstatic
4095                   *this-class*
4096                   g
4097                   +lisp-object+))
4098
4099;;              )
4100           )
4101          (t
4102           (setf (compiland-classfile compiland)
4103                 (prog1
4104                    (%format nil "local-~D.class" *child-count*)
4105                    (incf *child-count*)))
4106           (let ((*current-compiland* compiland)
4107                 (*speed* *speed*)
4108                 (*safety* *safety*)
4109                 (*debug* *debug*)
4110                 compiled-function)
4111             (p2-compiland compiland)
4112             (setf compiled-function
4113                   (sys:load-compiled-function (compiland-classfile compiland)))
4114             (emit 'getstatic
4115                   *this-class*
4116                   (declare-object compiled-function)
4117                   +lisp-object+))))
4118    (cond
4119     ((null *closure-variables*)) ; Nothing to do.
4120     ((compiland-closure-register *current-compiland*)
4121      (emit 'aload (compiland-closure-register *current-compiland*))
4122      (emit-invokestatic +lisp-class+
4123                         "makeCompiledClosure"
4124                         "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
4125                         -1)
4126      (emit 'checkcast "org/armedbear/lisp/CompiledClosure")
4127      ) ; Stack: compiled-closure
4128     (t
4129      ;; Shouldn't happen.
4130      (aver (progn 'unexpected nil))
4131      (emit-push-constant-int 0)
4132      (emit 'anewarray "org/armedbear/lisp/LispObject")))
4133    (emit-move-from-stack target)))
4134
4135(defun p2-function (form &key (target *val*) representation)
4136  (let ((name (second form))
4137        (local-function))
4138    (cond ((symbolp name)
4139           (cond ((setf local-function (find-local-function name))
4140                  (dformat t "p2-function 1~%")
4141                  (when (eq (local-function-compiland local-function) *current-compiland*)
4142                    (emit 'aload 0) ; this
4143                    (emit-move-from-stack target)
4144                    (return-from p2-function))
4145                  (cond ((local-function-variable local-function)
4146                         (dformat t "p2-function 2~%")
4147                         (emit 'var-ref (local-function-variable local-function) :stack))
4148                        (t
4149                         (let ((g (if *compile-file-truename*
4150                                      (declare-local-function local-function)
4151                                      (declare-object (local-function-function local-function)))))
4152                           (emit 'getstatic
4153                                 *this-class*
4154                                 g
4155                                 +lisp-object+)))) ; Stack: template-function
4156                  (cond ((null *closure-variables*)) ; Nothing to do.
4157                        ((compiland-closure-register *current-compiland*)
4158                         (dformat t "p2-function 3~%")
4159                         (emit 'aload (compiland-closure-register *current-compiland*))
4160                         (emit-invokestatic +lisp-class+
4161                                            "makeCompiledClosure"
4162                                            "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
4163                                            -1)) ; Stack: compiled-closure
4164                        (t
4165                         (aver (progn 'unexpected nil))))
4166                  (emit-move-from-stack target))
4167                 ((inline-ok name)
4168                  (emit 'getstatic
4169                        *this-class*
4170                        (declare-function name)
4171                        +lisp-object+)
4172                  (emit-move-from-stack target))
4173                 (t
4174                  (emit 'getstatic
4175                        *this-class*
4176                        (declare-symbol name)
4177                        +lisp-symbol+)
4178                  (emit-invokevirtual +lisp-object-class+
4179                                      "getSymbolFunctionOrDie"
4180                                      "()Lorg/armedbear/lisp/LispObject;"
4181                                      0)
4182                  (emit-move-from-stack target))))
4183          ((and (consp name) (eq (car name) 'SETF))
4184           ; FIXME Need to check for NOTINLINE declaration!
4185           (cond ((member name *toplevel-defuns* :test #'equal)
4186                  (emit 'getstatic
4187                        *this-class*
4188                        (declare-setf-function name)
4189                        +lisp-object+)
4190                  (emit-move-from-stack target))
4191                 ((and (null *compile-file-truename*)
4192                       (fdefinition name))
4193                  (emit 'getstatic
4194                        *this-class*
4195                        (declare-object (fdefinition name))
4196                        +lisp-object+)
4197                  (emit-move-from-stack target))
4198                 (t
4199                  (emit 'getstatic
4200                        *this-class*
4201                        (declare-symbol (cadr name))
4202                        +lisp-symbol+)
4203                  (emit-invokevirtual +lisp-symbol-class+
4204                                      "getSymbolSetfFunctionOrDie"
4205                                      "()Lorg/armedbear/lisp/LispObject;"
4206                                      0)
4207                  (emit-move-from-stack target))))
4208          ((compiland-p name)
4209           (p2-lambda name target))
4210          (t
4211           (error "p2-function: unsupported case: ~S" form)))))
4212
4213(defun p2-ash (form &key (target *val*) representation)
4214  (dformat t "p2-ash form = ~S representation = ~S~%" form representation)
4215  (unless (check-args form 2)
4216    (compile-function-call form target representation)
4217    (return-from p2-ash))
4218  (let* ((args (cdr form))
4219         (len (length args))
4220         (arg1 (first args))
4221         (arg2 (second args))
4222         (var1 (unboxed-fixnum-variable arg1))
4223         (var2 (unboxed-fixnum-variable arg2)))
4224    (cond
4225     ((and (numberp arg1) (numberp arg2))
4226      (dformat t "p2-ash case 1~%")
4227      (compile-constant (ash arg1 arg2)
4228                        :target target
4229                        :representation representation))
4230     ((and var1 (fixnump arg2) (< 0 arg2 32))
4231      (dformat t "p2-ash case 2~%")
4232      (case representation
4233        (:unboxed-fixnum
4234         (emit-push-int var1)
4235         (emit-push-constant-int arg2)
4236         (emit 'ishl))
4237        (t
4238         (emit-push-int var1)
4239         (emit 'i2l)
4240         (emit-push-constant-int arg2)
4241         (emit 'lshl)
4242         (emit-box-long)))
4243      (emit-move-from-stack target representation))
4244     ((and var1 (fixnump arg2) (< -32 arg2 0))
4245      (dformat t "p2-ash case 3~%")
4246      (unless (eq representation :unboxed-fixnum)
4247        (emit 'new +lisp-fixnum-class+)
4248        (emit 'dup))
4249      (emit-push-int var1)
4250      (emit-push-constant-int (- arg2))
4251      (emit 'ishr)
4252      (unless (eq representation :unboxed-fixnum)
4253        (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2))
4254      (emit-move-from-stack target representation))
4255     (var2
4256      (dformat t "p2-ash case 4~%")
4257      (compile-form arg1 :target :stack)
4258      (maybe-emit-clear-values arg1)
4259      (emit 'iload (variable-register var2))
4260      (emit-invokevirtual +lisp-object-class+
4261                          "ash"
4262                          "(I)Lorg/armedbear/lisp/LispObject;"
4263                          -1)
4264      (when (eq representation :unboxed-fixnum)
4265        (emit-unbox-fixnum))
4266      (emit-move-from-stack target representation))
4267     ((fixnump arg2)
4268      (dformat t "p2-ash case 5~%")
4269      (compile-form arg1 :target :stack)
4270      (maybe-emit-clear-values arg1)
4271      (emit-push-constant-int arg2)
4272      (emit-invokevirtual +lisp-object-class+
4273                          "ash"
4274                          "(I)Lorg/armedbear/lisp/LispObject;"
4275                          -1)
4276      (when (eq representation :unboxed-fixnum)
4277        (emit-unbox-fixnum))
4278      (emit-move-from-stack target representation))
4279     (t
4280      (dformat t "p2-ash case 6~%")
4281      (compile-function-call form target representation)))))
4282
4283(defun p2-logand (form &key (target *val*) representation)
4284  (let* ((args (cdr form))
4285         (len (length args)))
4286    (when (= len 2)
4287      (let* ((arg1 (first args))
4288             (arg2 (second args))
4289             (var1 (unboxed-fixnum-variable arg1)))
4290        (dformat t "p2-logand var1 = ~S~%" var1)
4291        (dformat t "p2-logand type-of arg2 is ~S~%" (type-of arg2))
4292        (cond
4293         ((and (integerp arg1) (integerp arg2))
4294          (dformat t "p2-logand case 1~%")
4295          (compile-constant (logand arg1 arg2) :target target :representation representation)
4296          (return-from p2-logand t))
4297         ((and (fixnump arg2) (zerop arg2))
4298          (dformat t "p2-logand case 2~%")
4299          (compile-constant 0 :target target :representation representation)
4300          (return-from p2-logand t))
4301         ((and var1 (fixnump arg2))
4302          (dformat t "p2-logand case 3~%")
4303          (unless (eq representation :unboxed-fixnum)
4304            (emit 'new +lisp-fixnum-class+)
4305            (emit 'dup))
4306          (emit 'iload (variable-register var1))
4307          (emit-push-constant-int arg2)
4308          (emit 'iand)
4309          (unless (eq representation :unboxed-fixnum)
4310            (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2))
4311          (emit-move-from-stack target representation)
4312          (return-from p2-logand t))
4313         ((fixnump arg2)
4314          (dformat t "p2-logand case 4~%")
4315          (let ((type (derive-type arg1)))
4316            (dformat t "p2-logand arg1 derived type = ~S~%" type)
4317            (cond
4318             ((subtypep type 'fixnum)
4319              (dformat t "p2-logand case 4a~%")
4320              (unless (eq representation :unboxed-fixnum)
4321                (emit 'new +lisp-fixnum-class+)
4322                (emit 'dup))
4323              (compile-form arg1 :target :stack :representation :unboxed-fixnum)
4324              (maybe-emit-clear-values arg1)
4325              (emit-push-constant-int arg2)
4326              (emit 'iand)
4327              (unless (eq representation :unboxed-fixnum)
4328                (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2))
4329              (emit-move-from-stack target representation))
4330             (t
4331              (dformat t "p2-logand case 4b~%")
4332              (compile-form arg1 :target :stack)
4333              (maybe-emit-clear-values arg1)
4334              (emit-push-constant-int arg2)
4335              (emit-invokevirtual +lisp-object-class+
4336                                  "logand"
4337                                  "(I)Lorg/armedbear/lisp/LispObject;"
4338                                  -1)
4339              (when (eq representation :unboxed-fixnum)
4340                (emit-unbox-fixnum))
4341              (emit-move-from-stack target representation))))
4342          (return-from p2-logand t))))))
4343  (dformat t "p2-logand default case~%")
4344  (compile-function-call form target representation))
4345
4346(defun derive-type (form)
4347  (cond
4348   ((fixnump form)
4349    (return-from derive-type 'fixnum))
4350   ((unboxed-fixnum-variable form)
4351    (return-from derive-type 'fixnum))
4352   ((consp form)
4353    (let ((op (first form)))
4354      (case op
4355        (ASH
4356         (dformat t "derive-type ASH case form = ~S~%" form)
4357         (let* ((arg1 (second form))
4358                (var1 (unboxed-fixnum-variable arg1))
4359                (arg2 (third form)))
4360           (dformat t "derive-type ASH case var1 = ~S~%" var1)
4361           (when (and var1 (fixnump arg2) (minusp arg2))
4362             (return-from derive-type 'FIXNUM))))
4363        (THE
4364         (dformat t "derive-type THE case form = ~S~%" form)
4365         (when (subtypep (second form) 'FIXNUM)
4366           (dformat t "derive-type THE case form = ~S returning FIXNUM~%" form)
4367           (return-from derive-type 'FIXNUM))
4368         )))))
4369  t)
4370
4371(defun compile-length (form &key (target *val*) representation)
4372  (check-args form 1)
4373  (let ((arg (cadr form)))
4374    (compile-form arg :target :stack)
4375    (maybe-emit-clear-values arg)
4376    (cond
4377     ((eq representation :unboxed-fixnum)
4378      (emit-invokevirtual +lisp-object-class+
4379                          "length"
4380                          "()I"
4381                          0))
4382     (t
4383      (emit-invokevirtual +lisp-object-class+
4384                          "LENGTH"
4385                          "()Lorg/armedbear/lisp/LispObject;"
4386                          0)))
4387    (emit-move-from-stack target representation)))
4388
4389(defun compile-nth (form &key (target *val*) representation)
4390  (unless (check-args form 2)
4391    (compile-function-call form target representation)
4392    (return-from compile-nth))
4393  (let ((index-form (second form))
4394        (list-form (third form)))
4395    (compile-form index-form :target :stack :representation :unboxed-fixnum)
4396    (compile-form list-form :target :stack)
4397    (unless (and (single-valued-p index-form)
4398                 (single-valued-p list-form))
4399      (emit-clear-values))
4400    (emit 'swap)
4401    (emit-invokevirtual +lisp-object-class+
4402                        "NTH"
4403                        "(I)Lorg/armedbear/lisp/LispObject;"
4404                        -1)
4405    (when (eq representation :unboxed-fixnum)
4406      (emit-unbox-fixnum))
4407    (emit-move-from-stack target representation)))
4408
4409(defun compile-plus (form &key (target *val*) representation)
4410  (case (length form)
4411    (3
4412     (let* ((args (cdr form))
4413            (arg1 (first args))
4414            (arg2 (second args))
4415            (var1 (unboxed-fixnum-variable arg1))
4416            (var2 (unboxed-fixnum-variable arg2)))
4417       (cond
4418        ((and (numberp arg1) (numberp arg2))
4419         (compile-constant (+ arg1 arg2)
4420                           :target target
4421                           :representation representation))
4422        ((and var1 var2)
4423         (dformat t "compile-plus case 1~%")
4424         (dformat t "target = ~S representation = ~S~%" target representation)
4425         (aver (variable-register var1))
4426         (aver (variable-register var2))
4427         (when target
4428           (cond
4429            ((eq representation :unboxed-fixnum)
4430             (emit-push-int var1)
4431             (emit-push-int arg2)
4432             (emit 'iadd))
4433            (t
4434             (emit 'iload (variable-register var1))
4435             (emit 'i2l)
4436             (emit 'iload (variable-register var2))
4437             (emit 'i2l)
4438             (emit 'ladd)
4439             (emit-box-long)))
4440           (emit-move-from-stack target representation)))
4441        ((and var1 (fixnump arg2))
4442         (dformat t "compile-plus case 2~%")
4443         (aver (variable-register var1))
4444         (cond
4445          ((eq representation :unboxed-fixnum)
4446           (emit-push-int var1)
4447           (emit-push-int arg2)
4448           (emit 'iadd))
4449          (t
4450           (emit-push-int var1)
4451           (emit 'i2l)
4452           (emit-push-int arg2)
4453           (emit 'i2l)
4454           (emit 'ladd)
4455           (emit-box-long)))
4456         (emit-move-from-stack target representation))
4457        ((and (fixnump arg1) var2)
4458         (dformat t "compile-plus case 3~%")
4459         (aver (variable-register var2))
4460         (cond
4461          ((eq representation :unboxed-fixnum)
4462           (emit-push-int arg1)
4463           (emit-push-int var2)
4464           (emit 'iadd))
4465          (t
4466           (emit-push-int arg1)
4467           (emit 'i2l)
4468           (emit-push-int var2)
4469           (emit 'i2l)
4470           (emit 'ladd)
4471           (emit-box-long)))
4472         (emit-move-from-stack target representation))
4473        ((eql arg1 1)
4474         (dformat t "compile-plus case 4~%")
4475         (compile-form arg2 :target :stack)
4476         (maybe-emit-clear-values arg2)
4477         (emit-invoke-method "incr" target representation))
4478        ((eql arg2 1)
4479         (dformat t "compile-plus case 5~%")
4480         (compile-form arg1 :target :stack)
4481         (maybe-emit-clear-values arg1)
4482         (emit-invoke-method "incr" target representation))
4483        ((arg-is-fixnum-p arg1)
4484         (dformat t "compile-plus case 6~%")
4485         (emit-push-int arg1)
4486         (compile-form arg2 :target :stack)
4487         (maybe-emit-clear-values arg2)
4488         (emit 'swap)
4489         (emit-invokevirtual +lisp-object-class+
4490                             "add"
4491                             "(I)Lorg/armedbear/lisp/LispObject;"
4492                             -1)
4493         (when (eq representation :unboxed-fixnum)
4494           (emit-unbox-fixnum))
4495         (emit-move-from-stack target representation))
4496        ((arg-is-fixnum-p arg2)
4497         (dformat t "compile-plus case 7~%")
4498         (compile-form arg1 :target :stack)
4499         (maybe-emit-clear-values arg1)
4500         (emit-push-int arg2)
4501         (emit-invokevirtual +lisp-object-class+
4502                             "add"
4503                             "(I)Lorg/armedbear/lisp/LispObject;"
4504                             -1)
4505         (when (eq representation :unboxed-fixnum)
4506           (emit-unbox-fixnum))
4507         (emit-move-from-stack target representation))
4508        (t
4509         (dformat t "compile-plus case 8~%")
4510         (compile-binary-operation "add" args target representation)))))
4511    (4
4512     (dformat t "compile-plus case 9~%")
4513     ;; (+ a b c) => (+ (+ a b) c)
4514     (let ((new-form `(+ (+ ,(second form) ,(third form)) ,(fourth form))))
4515       (dformat t "form = ~S~%" form)
4516       (dformat t "new-form = ~S~%" new-form)
4517       (compile-plus new-form :target target :representation representation)))
4518    (t
4519     (dformat t "compile-plus case 10~%")
4520     (compile-function-call form target representation))))
4521
4522(defun compile-minus (form &key (target *val*) representation)
4523  (case (length form)
4524    (3
4525     (let* ((args (cdr form))
4526            (arg1 (first args))
4527            (arg2 (second args))
4528            (var1 (unboxed-fixnum-variable arg1))
4529            (var2 (unboxed-fixnum-variable arg2)))
4530       (cond
4531        ((and (numberp arg1) (numberp arg2))
4532         (compile-constant (- arg1 arg2)
4533                           :target target
4534                           :representation representation))
4535        ((and var1 var2)
4536         (dformat t "compile-minus case 1~%")
4537         (aver (variable-register var1))
4538         (aver (variable-register var2))
4539         (when target
4540           (cond
4541            ((eq representation :unboxed-fixnum)
4542             (emit 'iload (variable-register var1))
4543             (emit 'iload (variable-register var2))
4544             (emit 'isub))
4545            (t
4546             (emit 'iload (variable-register var1))
4547             (emit 'i2l)
4548             (emit 'iload (variable-register var2))
4549             (emit 'i2l)
4550             (emit 'lsub)
4551             (emit-box-long)))
4552           (emit-move-from-stack target representation)))
4553        ((and var1 (fixnump arg2))
4554         (dformat t "compile-minus case 2~%")
4555         (aver (variable-register var1))
4556         (cond
4557          ((eq representation :unboxed-fixnum)
4558           (emit-push-int var1)
4559           (emit-push-int arg2)
4560           (emit 'isub))
4561          (t
4562           (emit-push-int var1)
4563           (emit 'i2l)
4564           (emit-push-int arg2)
4565           (emit 'i2l)
4566           (emit 'lsub)
4567           (emit-box-long)))
4568         (emit-move-from-stack target representation))
4569        ((and (fixnump arg1) var2)
4570         (dformat t "compile-minus case 3~%")
4571         (aver (variable-register var2))
4572         (cond
4573          ((eq representation :unboxed-fixnum)
4574           (emit-push-int arg1)
4575           (emit-push-int var2)
4576           (emit 'isub))
4577          (t
4578           (emit-push-int arg1)
4579           (emit 'i2l)
4580           (emit-push-int var2)
4581           (emit 'i2l)
4582           (emit 'lsub)
4583           (emit-box-long)))
4584         (emit-move-from-stack target representation))
4585        ((eql arg2 1)
4586         (dformat t "compile-minus case 5~%")
4587         (compile-form arg1 :target :stack)
4588         (maybe-emit-clear-values arg2)
4589         (emit-invoke-method "decr" target representation))
4590        ((arg-is-fixnum-p arg2)
4591         (dformat t "compile-minus case 7~%")
4592         (compile-form arg1 :target :stack)
4593         (maybe-emit-clear-values arg1)
4594         (emit-push-int arg2)
4595         (emit-invokevirtual +lisp-object-class+
4596                             "subtract"
4597                             "(I)Lorg/armedbear/lisp/LispObject;"
4598                             -1)
4599         (when (eq representation :unboxed-fixnum)
4600           (emit-unbox-fixnum))
4601         (emit-move-from-stack target representation))
4602        (t
4603         (dformat t "compile-minus case 8~%")
4604         (compile-binary-operation "subtract" args target representation)))))
4605    (4
4606     (dformat t "compile-minus case 9~%")
4607     ;; (- a b c) => (- (- a b) c)
4608     (let ((new-form `(- (- ,(second form) ,(third form)) ,(fourth form))))
4609       (dformat t "form = ~S~%" form)
4610       (dformat t "new-form = ~S~%" new-form)
4611       (compile-minus new-form :target target :representation representation)))
4612    (t
4613     (dformat t "compile-minus case 10~%")
4614     (compile-function-call form target representation))))
4615
4616(defun compile-schar (form &key (target *val*) representation)
4617  (unless (= (length form) 3)
4618    (error 'program-error
4619           :format-control "Wrong number of arguments for ~S."
4620           :format-arguments (list (car form))))
4621  (compile-form (second form) :target :stack)
4622  (compile-form (third form) :target :stack :representation :unboxed-fixnum)
4623  (unless (and (single-valued-p (second form))
4624               (single-valued-p (third form)))
4625    (emit-clear-values))
4626  (emit-invokevirtual +lisp-object-class+
4627                      "SCHAR"
4628                      "(I)Lorg/armedbear/lisp/LispObject;"
4629                      -1)
4630  (emit-move-from-stack target))
4631
4632(defun compile-aref (form &key (target *val*) representation)
4633;;   (dformat t "compile-aref form = ~S~%" form)
4634  (unless (= (length form) 3)
4635    (return-from compile-aref (compile-function-call form target representation)))
4636  (compile-form (second form) :target :stack)
4637  (compile-form (third form) :target :stack :representation :unboxed-fixnum)
4638  (unless (and (single-valued-p (second form))
4639               (single-valued-p (third form)))
4640    (emit-clear-values))
4641  (emit-invokevirtual +lisp-object-class+
4642                      "AREF"
4643                      "(I)Lorg/armedbear/lisp/LispObject;"
4644                      -1)
4645  (emit-move-from-stack target))
4646
4647(defun compile-not/null (form &key (target *val*) representation)
4648  (unless (= (length form) 2)
4649    (error 'program-error
4650           :format-control "Wrong number of arguments for ~S."
4651           :format-arguments (list (car form))))
4652  (let ((arg (second form)))
4653;;     (dformat t "arg = ~S~%" arg)
4654    (cond ((null arg)
4655           (emit-push-t))
4656          ((and (constantp arg) (not (block-node-p arg)))
4657;;            (dformat t "compile-not/null constantp case~%")
4658           (emit-push-nil))
4659          ((and (consp arg)
4660                (memq (car arg) '(NOT NULL)))
4661           (compile-form (second arg) :target :stack)
4662           (maybe-emit-clear-values (second arg))
4663           (emit-push-nil)
4664           (let ((label1 (gensym))
4665                 (label2 (gensym)))
4666             (emit 'if_acmpeq `,label1)
4667             (emit-push-t)
4668             (emit 'goto `,label2)
4669             (emit 'label `,label1)
4670             (emit-push-nil)
4671             (emit 'label `,label2)))
4672          (t
4673           (compile-form arg :target :stack)
4674           (maybe-emit-clear-values arg)
4675           (emit-push-nil)
4676           (let ((label1 (gensym))
4677                 (label2 (gensym)))
4678             (emit 'if_acmpeq `,label1)
4679             (emit-push-nil)
4680             (emit 'goto `,label2)
4681             (emit 'label `,label1)
4682             (emit-push-t)
4683             (emit 'label `,label2)))))
4684  (emit-move-from-stack target))
4685
4686(defun compile-values (form &key (target *val*) representation)
4687  (let ((args (cdr form)))
4688    (case (length args)
4689      (1
4690       (let ((arg (first args)))
4691         (compile-form arg :target target)
4692         (unless (single-valued-p arg)
4693           (emit-clear-values))))
4694      (2
4695       (emit-push-current-thread)
4696       (let ((arg1 (first args))
4697             (arg2 (second args)))
4698         (cond ((and (eq arg1 t)
4699                     (eq arg2 t))
4700                (emit-push-t)
4701                (emit 'dup))
4702               ((and (eq arg1 nil)
4703                     (eq arg2 nil))
4704                (emit-push-nil)
4705                (emit 'dup))
4706               (t
4707                (compile-form arg1 :target :stack)
4708                (compile-form arg2 :target :stack))))
4709       (emit-invokevirtual +lisp-thread-class+
4710                           "setValues"
4711                           "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
4712                           -2)
4713       (emit-move-from-stack target))
4714      (3
4715       (emit-push-current-thread)
4716       (dolist (arg args)
4717         (compile-form arg :target :stack))
4718       (emit-invokevirtual +lisp-thread-class+
4719                           "setValues"
4720                           "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
4721                           -3)
4722       (emit-move-from-stack target))
4723      (t
4724       (compile-function-call form target representation)))))
4725
4726(defun compile-special-reference (name target representation)
4727  (emit 'getstatic
4728        *this-class*
4729        (declare-symbol name)
4730        +lisp-symbol+)
4731  (emit-push-current-thread)
4732  (emit-invokevirtual +lisp-symbol-class+
4733                      "symbolValue"
4734                      "(Lorg/armedbear/lisp/LispThread;)Lorg/armedbear/lisp/LispObject;"
4735                      -1)
4736  (when (eq representation :unboxed-fixnum)
4737    (emit-unbox-fixnum))
4738  (emit-move-from-stack target representation))
4739
4740(defun compile-variable-reference (name target representation)
4741  (dformat t "compile-variable-reference ~S~%" name)
4742  (let ((variable (find-visible-variable name)))
4743    (cond
4744     ((null variable)
4745      (when (and (special-variable-p name)
4746                 (constantp name))
4747        (let ((value (symbol-value name)))
4748          (when (or (null *compile-file-truename*)
4749                    ;; FIXME File compilation doesn't support all constant
4750                    ;; types yet.
4751                    (stringp value)
4752                    (numberp value)
4753                    (packagep value))
4754            (compile-constant value :target target :representation representation)
4755            (return-from compile-variable-reference))))
4756      (unless (special-variable-p name)
4757        (unless (memq name *undefined-variables*)
4758          (compiler-warn "Undefined variable ~S" name)
4759          (push name *undefined-variables*)))
4760      (compile-special-reference name target representation))
4761     ((eq (variable-representation variable) :unboxed-fixnum)
4762      (dformat t "compile-variable-reference unboxed-fixnum case~%")
4763      (cond
4764       ((eq representation :unboxed-fixnum)
4765        (aver (variable-register variable))
4766        (emit 'iload (variable-register variable)))
4767       (t
4768        (dformat t "compile-variable-reference constructing boxed fixnum for ~S~%"
4769                 name)
4770        (emit 'new +lisp-fixnum-class+)
4771        (emit 'dup)
4772        (aver (variable-register variable))
4773        (emit 'iload (variable-register variable))
4774        (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)))
4775      (emit-move-from-stack target representation))
4776     (t
4777;;       (dformat t "compile-variable-reference name = ~S representation = ~S~%"
4778;;                name representation)
4779      (dformat t "compile-variable-reference ~S closure index = ~S~%"
4780               name (variable-closure-index variable))
4781      (emit 'var-ref variable target representation)))))
4782
4783(defun rewrite-setq (form)
4784  (let ((expr (third form)))
4785    (if (unsafe-p expr)
4786        (let ((sym (gensym)))
4787          (list 'LET (list (list sym expr)) (list 'SETQ (second form) sym)))
4788        form)))
4789
4790(defun compile-setq (form &key (target *val*) representation)
4791;;   (dformat t "compile-setq form = ~S target = ~S representation = ~S~%"
4792;;            form target representation)
4793  (unless (= (length form) 3)
4794    (return-from compile-setq (compile-form (precompiler::precompile-setq form)
4795                                            :target target)))
4796  (let ((expansion (macroexpand (second form))))
4797    (unless (eq expansion (second form))
4798      (compile-form (list 'SETF expansion (third form)))
4799      (return-from compile-setq)))
4800  (let* ((name (second form))
4801         (value-form (third form))
4802         (variable (find-visible-variable name)))
4803    (cond ((or (null variable)
4804               (variable-special-p variable))
4805           (let ((new-form (rewrite-setq form)))
4806             (when (neq new-form form)
4807               (return-from compile-setq (compile-form (p1 new-form) :target target))))
4808           (emit-push-current-thread)
4809           (emit 'getstatic
4810                 *this-class*
4811                 (declare-symbol name)
4812                 +lisp-symbol+)
4813           (compile-form value-form :target :stack)
4814           (maybe-emit-clear-values value-form)
4815           (emit-invokevirtual +lisp-thread-class+
4816                              "setSpecialVariable"
4817                              "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
4818                              -2)
4819           (emit-move-from-stack target))
4820          ((and (eq (variable-representation variable) :unboxed-fixnum)
4821                (or (equal value-form (list '1+ (variable-name variable)))
4822                    (equal value-form (list '+ (variable-name variable) 1))
4823                    (equal value-form (list '+ 1 (variable-name variable)))))
4824           (dformat t "compile-setq incf unboxed-fixnum case~%")
4825           (emit 'iinc (variable-register variable) 1)
4826           (when target
4827             (dformat t "compile-setq constructing boxed fixnum for ~S~%"
4828                      (variable-name variable))
4829             (emit 'new +lisp-fixnum-class+)
4830             (emit 'dup)
4831             (aver (variable-register variable))
4832             (emit 'iload (variable-register variable))
4833             (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)
4834             (emit-move-from-stack target)))
4835          ((eq (variable-representation variable) :unboxed-fixnum)
4836           (dformat t "compile-setq unboxed-fixnum case value-form = ~S~%" value-form)
4837           (compile-form value-form :target :stack)
4838           (maybe-emit-clear-values value-form)
4839           (when target
4840             (emit 'dup))
4841           (emit-unbox-fixnum)
4842           (emit 'istore (variable-register variable))
4843           (when target
4844             (emit-move-from-stack target))
4845           )
4846          (t
4847           (compile-form value-form :target :stack)
4848           (maybe-emit-clear-values value-form)
4849           (when target
4850             (emit 'dup))
4851           (emit 'var-set variable)
4852           (when target
4853             (when (eq representation :unboxed-fixnum)
4854               (emit-unbox-fixnum))
4855             (emit-move-from-stack target))))))
4856
4857(defun p2-the (form &key (target *val*) representation)
4858  (compile-form (third form) :target target :representation representation))
4859
4860(defun compile-catch (form &key (target *val*) representation)
4861  (when