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

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

Work in progress.

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