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

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

Unboxed fixnums (work in progress).

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