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

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

Work in progress (tested).

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