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

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

Work in progress (tested).

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