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

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

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

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