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

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

COMPILE-CONS

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