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

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

Work in progress (tested).

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