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

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

Work in progress (tested).

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