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

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

Work in progress.

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