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

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

Work in progress (tested).

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