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

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

Work in progress (tested).

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