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

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

Work in progress (tested).

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