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

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

Work in progress (tested).

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