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

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

Work in progress (tested).

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