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

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

Work in progress (tested).

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