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

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

Work in progress (tested).

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