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

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

Work in progress (tested).

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