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

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

Work in progress (tested).

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