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

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

Work in progress (tested).

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