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

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

Work in progress (tested).

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