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

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

Work in progress (tested).

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