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

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

Work in progress (tested).

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