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

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

Work in progress (tested).

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