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

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

Work in progress (tested).

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