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

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

Work in progress.

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