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

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

Work in progress (tested).

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