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

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

Work in progress (tested).

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