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

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

Work in progress (tested).

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