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

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

Work in progress (tested).

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