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

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

Work in progress (tested).

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