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

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

Work in progress (tested).

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