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

Last change on this file since 4682 was 4682, checked in by piso, 18 years ago

Work in progress.

File size: 75.7 KB
Line 
1;;; jvm.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: jvm.lisp,v 1.21 2003-11-08 20:17:34 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(require 'transform)
21
22(in-package "JVM")
23
24(export '(jvm-compile jvm-compile-package))
25
26(shadow 'method)
27
28(defvar *instructions*
29  '(nop             aconst_null  iconst_m1       iconst_0      iconst_1     ;   0
30    iconst_2        iconst_3     iconst_4        iconst_5      lconst_0     ;   5
31    lconst_1        fconst_0     fconst_1        fconst_2      dconst_0     ;  10
32    dconst_1        bipush       sipush          ldc           ldc_w        ;  15
33    ldc2_w          iload        lload           fload         dload        ;  20
34    aload           iload_0      iload_1         iload_2       iload_3      ;  25
35    lload_0         lload_1      lload_2         lload_3       fload_0      ;  30
36    fload_1         fload_2      fload_3         dload_0       dload_1      ;  35
37    dload_2         dload_3      aload_0         aload_1       aload_2      ;  40
38    aload_3         iaload       laload          faload        daload       ;  45
39    aaload          baload       caload          saload        istore       ;  50
40    lstore          fstore       dstore          astore        istore_0     ;  55
41    istore_1        istore_2     istore_3        lstore_0      lstore_1     ;  60
42    lstore_2        lstore_3     fstore_0        fstore_1      fstore_2     ;  65
43    fstore_3        dstore_0     dstore_1        dstore_2      dstore_3     ;  70
44    astore_0        astore_1     astore_2        astore_3      iastore      ;  75
45    lastore         fastore      dastore         aastore       bastore      ;  80
46    castore         sastore      pop             pop2          dup          ;  85
47    dup_x1          dup_x2       dup2            dup2_x1       dup2_x2      ;  90
48    swap            iadd         ladd            fadd          dadd         ;  95
49    isub            lsub         fsub            dsub          imul         ; 100
50    lmul            fmul         dmul            idiv          ldiv         ; 105
51    fdiv            ddiv         irem            lrem          frem         ; 110
52    drem            ineg         lneg            fneg          dneg         ; 115
53    ishl            lshl         ishr            lshr          iushr        ; 120
54    lushr           iand         land            ior           lor          ; 125
55    ixor            lxor         iinc            i2l           i2f          ; 130
56    i2d             l2i          l2f             l2d           f2i          ; 135
57    f2l             f2d          d2i             d2l           d2f          ; 140
58    i2b             i2c          i2s             lcmp          fcmpl        ; 145
59    fcmpg           dcmpl        dcmpg           ifeq          ifne         ; 150
60    iflt            ifge         ifgt            ifle          if_icmpeq    ; 155
61    if_icmpne       if_icmplt    if_icmpge       if_icmpgt     if_icmple    ; 160
62    if_acmpeq       if_acmpne    goto            jsr           ret          ; 165
63    tableswitch     lookupswitch ireturn         lreturn       freturn      ; 170
64    dreturn         areturn      return          getstatic     putstatic    ; 175
65    getfield        putfield     invokevirtual   invokespecial invokestatic ; 180
66    invokeinterface unused       new             newarray      anewarray    ; 185
67    arraylength     athrow       checkcast       instanceof    monitorenter ; 190
68    monitorexit     wide         multianewarray  ifnull        ifnonnull    ; 195
69    goto_w          jsr_w        label                                      ; 200
70    ))
71
72(unless (vectorp *instructions*)
73  (let* ((list *instructions*)
74         (vector (make-array (length *instructions*)))
75         (index 0))
76    (dolist (instr list)
77      (setf (get instr 'opcode) index)
78      (setf (svref vector index) instr)
79      (incf index))
80    (setq *instructions* vector)))
81
82(defun instr (opcode)
83  (svref *instructions* opcode))
84
85(defparameter *opcode-size*
86  ;; 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9
87  '#(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 3 2 3  ;; 000-019
88     3 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1  ;; 020-039
89     1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 1  ;; 040-059
90     1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1  ;; 060-079
91     1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1  ;; 080-099
92     1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1  ;; 100-119
93     1 1 1 1 1 1 1 1 1 1 1 1 3 1 1 1 1 1 1 1  ;; 120-139
94     1 1 1 1 1 1 1 1 1 1 1 1 1 3 3 3 3 3 3 3  ;; 140-159
95     3 3 3 3 3 3 3 3 3 2 0 0 1 1 1 1 1 1 3 3  ;; 160-179
96     3 3 3 3 3 5 0 3 2 3 1 1 3 3 1 1 0 4 3 3  ;; 180-199
97     5 5 0                                    ;; 200-202
98     ))
99
100(defun opcode-size (opcode)
101  (svref *opcode-size* opcode))
102
103(defvar *pool* nil)
104
105(defun read-u1 (stream)
106  (read-byte stream))
107
108(defun read-u2 (stream)
109  (+ (ash (read-byte stream) 8) (read-byte stream)))
110
111(defun read-u4 (stream)
112  (+ (ash (read-u2 stream) 16) (read-u2 stream)))
113
114(defun lookup-utf8 (index)
115  (let ((entry (svref *pool* index)))
116    (when (eql (car entry) 1)
117      (caddr entry))))
118
119(defun read-constant-pool-entry (stream)
120  (let ((tag (read-u1 stream))
121        info)
122    (case tag
123      ((7 8)
124       (list tag (read-u2 stream)))
125      (1
126       (let* ((len (read-u2 stream))
127              (s (make-string len)))
128         (dotimes (i len)
129;;            (setf (char s i) (coerce (read-u1 stream) 'character)))
130           (setf (char s i) (code-char (read-u1 stream))))
131         (list tag len s)))
132      ((3 4)
133       (list tag (read-u4 stream)))
134      ((5 6)
135       (list tag (read-u4 stream) (read-u4 stream)))
136      ((12 9 10 11)
137       (list tag (read-u2 stream) (read-u2 stream)))
138      (t
139       (error "READ-CONSTANT-POOL-ENTRY unhandled tag ~D" tag)))))
140
141(defvar *indent* 0)
142
143(defparameter *spaces* (make-string 256 :initial-element #\space))
144
145(defmacro out (&rest args)
146  `(progn (format t (subseq *spaces* 0 *indent*)) (format t ,@args)))
147
148(defun dump-code (code)
149  (let ((code-length (length code)))
150    (do ((i 0))
151        ((>= i code-length))
152      (let* ((opcode (svref code i))
153             (size (opcode-size opcode)))
154        (out "~D (#x~X) ~A~%" opcode opcode (instr opcode))
155        (incf i)
156        (dotimes (j (1- size))
157          (let ((byte (svref code i)))
158            (out "~D (#x~X)~%" byte byte))
159          (incf i))))))
160
161(defun dump-code-attribute (stream)
162  (let ((*indent* (+ *indent* 2)))
163    (out "Stack: ~D~%" (read-u2 stream))
164    (out "Locals: ~D~%" (read-u2 stream))
165    (let* ((code-length (read-u4 stream))
166           (code (make-array code-length)))
167      (out "Code length: ~D~%" code-length)
168      (out "Code:~%")
169      (dotimes (i code-length)
170        (setf (svref code i) (read-u1 stream)))
171      (let ((*indent* (+ *indent* 2)))
172        (dump-code code)))
173    (let ((exception-table-length (read-u2 stream)))
174      (out "Exception table length: ~D~%" exception-table-length)
175      (let ((*indent* (+ *indent* 2)))
176        (dotimes (i exception-table-length)
177          (out "Start PC: ~D~%" (read-u2 stream))
178          (out "End PC: ~D~%" (read-u2 stream))
179          (out "Handler PC: ~D~%" (read-u2 stream))
180          (out "Catch type: ~D~%" (read-u2 stream)))))
181    (let ((attributes-count (read-u2 stream)))
182      (out "Number of attributes: ~D~%" attributes-count)
183      (let ((*indent* (+ *indent* 2)))
184        (dotimes (i attributes-count)
185          (read-attribute i stream))))))
186
187(defun dump-exceptions (stream)
188  )
189
190(defun read-attribute (index stream)
191  (let* ((name-index (read-u2 stream))
192         (length (read-u4 stream))
193         (*indent (+ *indent* 2)))
194    (setq name (lookup-utf8 name-index))
195    (out "Attribute ~D: Name index: ~D (~S)~%" index name-index name)
196    (out "Attribute ~D: Length: ~D~%" index length)
197    (cond ((string= name "Code")
198           (dump-code-attribute stream))
199          ((string= name "Exceptions")
200           (let ((count (read-u2 stream)))
201             (out "Attribute ~D: Number of exceptions: ~D~%" index count)
202             (let ((*indent* (+ *indent* 2)))
203               (dotimes (i count)
204                 (out "Exception ~D: ~D~%" i (read-u2 stream))))))
205          (t
206           (dotimes (i length)
207             (read-u1 stream))))))
208
209(defun read-info (index stream type)
210  (let* ((access-flags (read-u2 stream))
211         (name-index (read-u2 stream))
212         (descriptor-index (read-u2 stream))
213         (attributes-count (read-u2 stream))
214         (*indent* (+ *indent* 2))
215         (type (case type
216                 ('field "Field")
217                 ('method "Method")))
218         name)
219    (out "~A ~D: Access flags: #x~X~%" type index access-flags)
220    (out "~A ~D: Name index: ~D (~S)~%" type index name-index (lookup-utf8 name-index))
221    (out "~A ~D: Descriptor index: ~D~%" type index descriptor-index)
222    (out "~A ~D: Number of attributes: ~D~%" type index attributes-count)
223    (let ((*indent* (+ *indent* 2)))
224      (dotimes (i attributes-count)
225        (read-attribute i stream)))))
226
227(defun dump-class (filename)
228  (let ((*indent* 0)
229        (*pool* nil))
230    (with-open-file (stream filename :direction :input :element-type 'unsigned-byte)
231      (handler-bind ((end-of-file
232                      #'(lambda (c) (return-from dump-class c))))
233        (out "Magic number: #x~X~%" (read-u4 stream))
234        (let ((minor (read-u2 stream))
235              (major (read-u2 stream)))
236          (out "Version: ~D.~D~%" major minor))
237        ;; Constant pool.
238        (let ((count (read-u2 stream))
239              entry type)
240          (out "Constant pool (~D entries):~%" count)
241          (setq *pool* (make-array count))
242          (let ((*indent* (+ *indent* 2)))
243            (dotimes (index (1- count))
244              (setq entry (read-constant-pool-entry stream))
245              (setf (svref *pool* (1+ index)) entry)
246              (setq type (case (car entry)
247                           (7 'class)
248                           (9 'field)
249                           (10 'method)
250                           (11 'interface)
251                           (8 'string)
252                           (3 'integer)
253                           (4 'float)
254                           (5 'long)
255                           (6 'double)
256                           (12 'name-and-type)
257                           (1 'utf8)))
258              (out "~D: ~A ~S~%" (1+ index) type entry))))
259        (out "Access flags: #x~X~%" (read-u2 stream))
260        (out "This class: ~D~%" (read-u2 stream))
261        (out "Superclass: ~D~%" (read-u2 stream))
262        ;; Interfaces.
263        (let ((count (read-u2 stream)))
264          (cond ((zerop count)
265                 (out "No interfaces~%"))
266                (t
267                 (out "Interfaces (~D):~%" count)
268                 (dotimes (i count)
269                   (out "  ~D: ~D~%" i (read-u2 stream))))))
270        ;; Fields.
271        (let ((count (read-u2 stream)))
272          (cond ((zerop count)
273                 (out "No fields~%"))
274                (t
275                 (out "Fields (~D):~%" count)))
276          (dotimes (index count)
277            (read-info index stream 'field)))
278        ;; Methods.
279        (let ((count (read-u2 stream)))
280          (cond ((zerop count)
281                 (out "No methods~%"))
282                (t
283                 (out "Methods (~D):~%" count)))
284          (dotimes (index count)
285            (read-info index stream 'method)))
286        (let ((count (read-u2 stream)))
287          (cond ((zerop count)
288                 (out "No attributes~%"))
289                (t
290                 (out "Attributes (~D):~%" count)))))))
291  t)
292
293(defvar *stream* nil)
294(defvar *defun-name* nil)
295(defvar *this-class* nil)
296(defvar *pool-count* 1)
297
298(defvar *code* ())
299(defvar *static-code* ())
300(defvar *fields* ())
301
302(defvar *blocks* ())
303(defvar *locals* ())
304(defvar *max-locals* 0)
305
306;; (defun allocate-local ()
307;;   (let ((index (fill-pointer *locals*)))
308;;     (incf (fill-pointer *locals*))
309;;     (setf *max-locals* (fill-pointer *locals*))
310;;     index))
311
312(defvar *args* nil)
313(defvar *using-arg-array* nil)
314(defvar *hairy-arglist-p* nil)
315
316(defvar *val* nil) ; index of value register
317
318(defun clear ()
319  (setq *pool* nil
320        *pool-count* 1
321        *code* nil)
322  t)
323
324(defun dump-pool ()
325  (let ((pool (reverse *pool*))
326        entry)
327    (dotimes (index (1- *pool-count*))
328      (setq entry (car pool))
329      (setq type (case (car entry)
330                   (7 'class)
331                   (9 'field)
332                   (10 'method)
333                   (11 'interface)
334                   (8 'string)
335                   (3 'integer)
336                   (4 'float)
337                   (5 'long)
338                   (6 'double)
339                   (12 'name-and-type)
340                   (1 'utf8)))
341      (format t "~D: ~A ~S~%" (1+ index) type entry)
342      (setq pool (cdr pool))))
343  t)
344
345;; Returns index of entry (1-based).
346(defun pool-add (entry)
347  (setq *pool* (cons entry *pool*))
348  (prog1
349    *pool-count*
350    (incf *pool-count*)))
351
352;; Returns index of entry (1-based).
353(defun pool-find-entry (entry)
354  (do* ((remaining *pool* (cdr remaining))
355        (i 0 (1+ i))
356        (current (car remaining) (car remaining)))
357       ((null remaining) nil)
358    (when (equal current entry)
359      (return-from pool-find-entry (- *pool-count* 1 i)))))
360
361;; Adds entry if not already in pool. Returns index of entry (1-based).
362(defun pool-get (entry)
363  (or (pool-find-entry entry) (pool-add entry)))
364
365(defun pool-name (name)
366  (pool-get (list 1 (length name) name)))
367
368;; "org.armedbear.lisp.LispObject" => "Lorg/armedbear/lisp/LispObject;"
369;; (defun type-descriptor (type)
370;;   (unless (find #\. type)
371;;     (setq type (concatenate 'string "org.armedbear.lisp." type)))
372;;   (let ((res (concatenate 'string "L" type ";")))
373;;     (dotimes (i (length res))
374;;       (when (eql (char res i) #\.)
375;;         (setf (char res i) #\/)))
376;;     res))
377
378(defun pool-name-and-type (name type)
379  (let* ((name-index (pool-name name))
380         (type-index (pool-name type)))
381    (pool-get (list 12 name-index type-index))))
382
383(defun pool-class (class-name)
384  (let ((class-name class-name))
385    (dotimes (i (length class-name))
386      (when (eql (char class-name i) #\.)
387        (setf (char class-name i) #\/)))
388    (pool-get (list 7 (pool-name class-name)))))
389
390;; (tag class-index name-and-type-index)
391(defun pool-field (class-name field-name type-name)
392  (let* ((class-index (pool-class class-name))
393         (name-and-type-index (pool-name-and-type field-name type-name)))
394    (pool-get (list 9 class-index name-and-type-index))))
395
396;; (tag class-index name-and-type-index)
397(defun pool-method (class-name method-name type-name)
398  (let* ((class-index (pool-class class-name))
399         (name-and-type-index (pool-name-and-type method-name type-name)))
400    (pool-get (list 10 class-index name-and-type-index))))
401
402(defun pool-string (string)
403  (pool-get (list 8 (pool-name string))))
404
405(defun u2 (n)
406  (list (ash n -8) (logand n #xff)))
407
408(defstruct instruction opcode args stack depth)
409
410(defun inst (opcode &optional args)
411  (unless (listp args)
412    (setq args (list args)))
413  (make-instruction :opcode opcode :args args :stack nil :depth nil))
414
415(defun emit (instr &rest args)
416  (unless (numberp instr)
417    (setq instr (get instr 'opcode)))
418  (let ((instruction (inst instr args)))
419    (setq *code* (cons instruction *code*))
420    instruction))
421
422(defmacro emit-store-value ()
423  `(case *val*
424     (0
425      (emit 'astore_0))
426     (1
427      (emit 'astore_1))
428     (2
429      (emit 'astore_2))
430     (3
431      (emit 'astore_3))
432     (t
433      (emit 'astore *val*))))
434
435(defmacro emit-push-value ()
436  `(case *val*
437     (0
438      (emit 'aload_0))
439     (1
440      (emit 'aload_1))
441     (2
442      (emit 'aload_2))
443     (3
444      (emit 'aload_3))
445     (t
446      (emit 'aload *val*))))
447
448(defun remove-store-value ()
449  (let* ((instruction (car *code*))
450         (opcode (instruction-opcode instruction))
451         slot)
452    (case opcode
453      (75
454       (setf slot 0))
455      (76
456       (setf slot 1))
457      (77
458       (setf slot 2))
459      (78
460       (setf slot 3))
461      (58
462       (setf slot (car (instruction-args instruction)))))
463    (when (and slot (= slot *val*))
464      (setf *code* (cdr *code*))
465      t)))
466
467(defconstant +lisp-class+ "org/armedbear/lisp/Lisp")
468(defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject")
469(defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;")
470(defconstant +lisp-string+ "Lorg/armedbear/lisp/LispString;")
471(defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol")
472(defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread")
473
474(defun emit-push-nil ()
475  (emit 'getstatic
476        +lisp-class+
477        "NIL"
478        +lisp-object+))
479
480(defun emit-push-t ()
481  (emit 'getstatic
482        +lisp-class+
483        "T"
484        "Lorg/armedbear/lisp/Symbol;"))
485
486(defun emit-invokestatic (class-name method-name descriptor stack)
487  (assert stack)
488  (let ((instruction (emit 'invokestatic class-name method-name descriptor)))
489    (setf (instruction-stack instruction) stack)
490    (assert (eql (instruction-stack instruction) stack))))
491
492(defun emit-invokespecial (class-name method-name descriptor stack)
493  (let ((instruction (emit 'invokespecial class-name method-name descriptor)))
494    (setf (instruction-stack instruction) stack)))
495
496(defun emit-invokevirtual (class-name method-name descriptor stack)
497  (let ((instruction (emit 'invokevirtual class-name method-name descriptor)))
498    (setf (instruction-stack instruction) stack)))
499
500;; Index of local variable used to hold the current thread.
501(defvar *thread* nil)
502(defvar *thread-var-initialized* nil)
503
504(defun ensure-thread-var-initialized ()
505  (unless *thread-var-initialized*
506    ;; Put the code to initialize the local at the very beginning of the
507    ;; function, to guarantee that the local gets initialized even if the code
508    ;; at our current location is never executed, since the local may be
509    ;; referenced elsewhere too.
510    (let ((code *code*))
511      (setf *code* ())
512      (emit-invokestatic +lisp-thread-class+
513                         "currentThread"
514                         "()Lorg/armedbear/lisp/LispThread;"
515                         1)
516      (emit 'astore *thread*)
517      (setf *code* (append code *code*)))
518    (setf *thread-var-initialized* t)))
519
520(defun emit-clear-values ()
521  (ensure-thread-var-initialized)
522  (emit 'aload *thread*)
523  (emit-invokevirtual +lisp-thread-class+ "clearValues" "()V" -1))
524
525(defun emit-invoke-method (method-name)
526  (unless (remove-store-value)
527    (emit-push-value))
528  (emit-invokevirtual +lisp-object-class+
529                      method-name
530                      "()Lorg/armedbear/lisp/LispObject;"
531                      0)
532  (emit-store-value))
533
534;; CODE is a list.
535(defun resolve-args (instruction)
536  (let ((opcode (instruction-opcode instruction))
537        (args (instruction-args instruction)))
538    (case opcode
539      ((1 ; ACONST_NULL
540        42 ; ALOAD_0
541        43 ; ALOAD_1
542        44 ; ALOAD_2
543        45 ; ALOAD_3
544        50 ; AALOAD
545        75 ; ASTORE_0
546        76 ; ASTORE_1
547        77 ; ASTORE_2
548        78 ; ASTORE_3
549        83 ; AASTORE
550        87 ; POP
551        89 ; DUP
552        95 ; SWAP
553        153 ; IFEQ
554        154 ; IFNE
555        166 ; IF_ACMPNE
556        165 ; IF_ACMPEQ
557        167 ; GOTO
558        176 ; ARETURN
559        177 ; RETURN
560        202 ; LABEL
561        )
562       instruction)
563      (25 ; ALOAD
564       (let ((index (car args)))
565         (cond ((= index 0)
566                (inst 42)) ; ALOAD_O
567               ((= index 1)
568                (inst 43)) ; ALOAD_1
569               ((= index 2)
570                (inst 44)) ; ALOAD_2
571               ((= index 3)
572                (inst 45)) ; ALOAD_3
573               ((<= 0 index 255)
574                (inst 25 index))
575               (t
576                (error "ALOAD unsupported case")))))
577      (58 ; ASTORE
578       (let ((index (car args)))
579         (cond ((= index 0)
580                (inst 75)) ; ASTORE_O
581               ((= index 1)
582                (inst 76)) ; ASTORE_1
583               ((= index 2)
584                (inst 77)) ; ASTORE_2
585               ((= index 3)
586                (inst 78)) ; ASTORE_3
587               ((<= 0 index 255)
588                (inst 58 index))
589               (t
590                (error "ASTORE unsupported case")))))
591      ((178 ; GETSTATIC class-name field-name type-name
592        179 ; PUTSTATIC class-name field-name type-name
593        )
594       (let ((index (pool-field (first args) (second args) (third args))))
595         (inst opcode (u2 index))))
596      ((182 ; INVOKEVIRTUAL class-name method-name descriptor
597        183 ; INVOKESPECIAL class-name method-name descriptor
598        184 ; INVOKESTATIC class-name method-name descriptor
599        )
600       (let ((index (pool-method (first args) (second args) (third args))))
601;;          (inst opcode (u2 index))))
602         (setf (instruction-args instruction) (u2 index))
603         instruction))
604      ((189 ; ANEWARRAY class-name
605        )
606       (let ((index (pool-class (first args))))
607         (inst opcode (u2 index))))
608      ((16 ; BIPUSH
609        17 ; SIPUSH
610        )
611       (let ((n (first args)))
612         (cond ((= n 0)
613                (inst 3)) ; ICONST_0
614               ((= n 1)
615                (inst 4)) ; ICONST_1
616               ((= n 2)
617                (inst 5)) ; ICONST_2
618               ((= n 3)
619                (inst 6)) ; ICONST_3
620               ((= n 4)
621                (inst 7)) ; ICONST_4
622               ((= n 5)
623                (inst 8)) ; ICONST_5
624               ((<= -128 n 127)
625                (inst 16 (logand n #xff))) ; BIPUSH
626               (t ; SIPUSH
627                (inst 17 (u2 n))))))
628      (18 ; LDC
629       (unless (= (length args) 1)
630         (error "wrong number of args for LDC"))
631       (if (> (car args) 255)
632           (inst 19 (u2 (car args))) ; LDC_W
633           (inst opcode args)))
634      (t
635       (error "RESOLVE-ARGS unsupported opcode ~D" opcode)))))
636
637;; CODE is a list of INSTRUCTIONs.
638(defun resolve-opcodes (code)
639  (map 'vector #'resolve-args code))
640
641(defun branch-opcode-p (opcode)
642  (member opcode
643    '(153 ; IFEQ
644      154 ; IFNE
645      165 ; IF_ACMPEQ
646      166 ; IF_ACMPNE
647      167 ; GOTO
648      )))
649
650(defun stack-effect (opcode)
651  (case opcode
652    ((25 ; ALOAD
653      42 ; ALOAD_0
654      43 ; ALOAD_1
655      44 ; ALOAD_2
656      45 ; ALOAD_3
657      )
658     1)
659    ((58 ; ASTORE
660      75 ; ASTORE_0
661      76 ; ASTORE_1
662      77 ; ASTORE_2
663      78 ; ASTORE_3
664      )
665     -1)
666    (50 ; AALOAD
667     -1)
668    (83 ; AASTORE
669     -3)
670    ((1 ; ACONST_NULL
671      3 4 5 6 7 8 ; ICONST_0 ... ICONST_5
672      16 ; BIPUSH
673      17 ; SIPUSH
674      )
675     1)
676    (18 ; LDC
677     1)
678    (178 ; GETSTATIC
679     1)
680    (179 ; PUTSTATIC
681     -1)
682    (189 ; ANEWARRAY
683     0)
684    ((153 ; IFEQ
685      )
686     -1)
687    ((165 ; IF_ACMPEQ
688      166 ; IF_ACMPNE
689      )
690     -2)
691    ((167 ; GOTO
692      202 ; LABEL
693      )
694     0)
695    (89 ; DUP
696     1)
697    (95 ; SWAP
698     0)
699    (87 ; POP
700     -1)
701    (176 ; ARETURN
702     -1)
703    (177 ; RETURN
704     0)
705    (t
706     (format t "STACK-EFFECT unsupported opcode ~S~%"
707             (instruction-opcode instruction))
708     0)))
709
710(defun walk-code (code start-index depth)
711  (do* ((i start-index (1+ i))
712        (limit (length code)))
713       ((>= i limit) depth)
714    (let ((instruction (svref code i)))
715      (when (instruction-depth instruction)
716        (return-from walk-code))
717      (setf (instruction-depth instruction) depth)
718      (setf depth (+ depth (instruction-stack instruction)))
719      (if (branch-opcode-p (instruction-opcode instruction))
720          (let ((label (car (instruction-args instruction))))
721;;             (format t "target = ~S~%" target)
722            (walk-code code (symbol-value label) depth)
723            )
724          ()))))
725
726(defun analyze-stack ()
727  (sys::require-type *code* 'vector)
728  (dotimes (i (length *code*))
729    (let* ((instruction (svref *code* i))
730           (opcode (instruction-opcode instruction)))
731      (when (eql opcode 202)
732        (let ((label (car (instruction-args instruction))))
733          (set label i)))
734      (unless (instruction-stack instruction)
735        (setf (instruction-stack instruction) (stack-effect opcode)))))
736  (walk-code *code* 0 0)
737  (let ((max-stack 0))
738    (dotimes (i (length *code*))
739      (let ((instruction (svref *code* i)))
740        (setf max-stack (max max-stack (instruction-depth instruction)))))
741;;     (format t "max-stack = ~D~%" max-stack)
742    max-stack))
743
744(defun finalize-code ()
745  (setf *code* (nreverse (coerce *code* 'vector))))
746
747(defun optimize-code ()
748  (dotimes (i (length *code*))
749    (let ((instruction (svref *code* i)))
750      (when (and (< i (1- (length *code*)))
751                 (= (instruction-opcode instruction) 167) ; GOTO
752                 (let ((next-instruction (svref *code* (1+ i))))
753                   (when (and (= (instruction-opcode next-instruction) 202) ; LABEL
754                              (eq (car (instruction-args instruction))
755                                  (car (instruction-args next-instruction))))
756                     (setf (instruction-opcode instruction) 0)))))))
757
758  (setf *code* (delete 0 *code* :key #'instruction-opcode))
759  )
760
761(defvar *max-stack*)
762
763;; CODE is a list of INSTRUCTIONs.
764(defun code-bytes (code)
765
766;;   (fresh-line)
767;;   (format t "-- begin code --~%")
768;;   (dotimes (i (length code))
769;;     (format t "~S~%" (svref code i)))
770;;   (format t "--- end code ---~%")
771
772;;   ;; Make a list of the labels that are actually branched to.
773;;   (let ((branch-targets ()))
774;;     (dotimes (i (length code))
775;;       (let ((instruction (svref code i)))
776;;         (when (branch-opcode-p (instruction-opcode instruction))
777;;           (push branch-targets (car (instruction-args instruction))))))
778;;     (format t "branch-targets = ~S~%" branch-targets)
779
780;;     ;; Remove labels that are not used as branch targets.
781;;     (dotimes (i (length code))
782;;       (let ((instruction (svref code i)))
783;;         (when (= (instruction-opcode instruction) 202) ; LABEL
784;;           (let ((label (car (instruction-args instruction))))
785;;             (unless (member label branch-targets)
786;;               (setf (instruction-opcode instruction) 0)))))))
787
788;;   (dotimes (i (length code))
789;;     (let ((instruction (svref code i)))
790;;       (when (and (< i (1- (length code)))
791;;                  (= (instruction-opcode instruction) 167) ; GOTO
792;;         (let ((next-instruction (svref code (1+ i))))
793;;           (when (and (= (instruction-opcode next-instruction) 202) ; LABEL
794;;                      (eq (car (instruction-args instruction))
795;;                          (car (instruction-args next-instruction))))
796;;             (setf (instruction-opcode instruction) 0)))))))
797
798;;   (setf code (delete 0 code :key #'instruction-opcode))
799
800;;   (fresh-line)
801;;   (format t "-- begin code --~%")
802;;   (dotimes (i (length code))
803;;     (format t "~S~%" (svref code i)))
804;;   (format t "--- end code ---~%")
805
806;;   (setf code (coerce code 'list))
807
808  ;; FIXME Do stack analysis here!
809;;   (setf *max-stack* (analyze-stack code))
810
811  (let ((code (resolve-opcodes code))
812        (length 0))
813    ;; Pass 1: calculate label offsets and overall length.
814    (dotimes (i (length code))
815      (let* ((instruction (aref code i))
816             (opcode (instruction-opcode instruction)))
817        (if (= opcode 202) ; LABEL
818            (let ((label (car (instruction-args instruction))))
819              (set label length))
820            (incf length (opcode-size opcode)))))
821    ;; Pass 2: replace labels with calculated offsets.
822    (let ((index 0))
823      (dotimes (i (length code))
824        (let ((instruction (aref code i)))
825          (when (branch-opcode-p (instruction-opcode instruction))
826            (let* ((label (car (instruction-args instruction)))
827                   (offset (- (symbol-value `,label) index)))
828              (setf (instruction-args instruction) (u2 offset))))
829          (unless (= (instruction-opcode instruction) 202) ; LABEL
830            (incf index (opcode-size (instruction-opcode instruction)))))))
831
832    ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
833    (let ((bytes (make-array length))
834          (index 0))
835      (dotimes (i (length code))
836        (let ((instruction (aref code i)))
837          (unless (= (instruction-opcode instruction) 202) ; LABEL
838            (setf (svref bytes index) (instruction-opcode instruction))
839            (incf index)
840            (dolist (byte (instruction-args instruction))
841              (setf (svref bytes index) byte)
842              (incf index)))))
843      bytes)))
844
845(defun write-u1 (n)
846  (write-byte (logand n #xFF) *stream*))
847
848(defun write-u2 (n)
849  (write-byte (ash n -8) *stream*)
850  (write-byte (logand n #xFF) *stream*))
851
852(defun write-u4 (n)
853  (write-u2 (ash n -16))
854  (write-u2 (logand n #xFFFF)))
855
856(defun write-utf8 (string)
857  (dotimes (i (length string))
858    (write-u1 (char-int (char string i)))))
859
860(defun write-cp-entry (entry)
861  (write-u1 (first entry))
862  (case (first entry)
863    (1
864     (write-u2 (second entry))
865     (write-utf8 (third entry)))
866    ((5 6)
867     (write-u4 (second entry))
868     (write-u4 (third entry)))
869    ((9 10 11 12)
870     (write-u2 (second entry))
871     (write-u2 (third entry)))
872    ((7 8)
873     (write-u2 (second entry)))
874    (t
875     (error "WRITE-CP-ENTRY unhandled tag ~D~%" (car entry)))
876  ))
877
878(defun write-pool ()
879  (write-u2 *pool-count*)
880  (dolist (entry (reverse *pool*))
881    (write-cp-entry entry)))
882
883(defstruct field
884  access-flags
885  name
886  descriptor
887  name-index
888  descriptor-index)
889
890(defstruct method
891  access-flags
892  name
893  descriptor
894  name-index
895  descriptor-index
896  max-stack
897  max-locals
898  code)
899
900(defun make-constructor (super name args body)
901  (let* ((constructor (make-method :name "<init>"
902                                   :descriptor "()V"))
903         (*code* ()))
904    (setf (method-name-index constructor) (pool-name (method-name constructor)))
905    (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor)))
906    (setf (method-max-locals constructor) 1)
907    (cond (*hairy-arglist-p*
908           (emit 'aload_0) ;; this
909           (emit 'aconst_null) ;; name
910           (let ((s (format nil "~S" args)))
911             (emit 'ldc
912                   (pool-string s))
913             (emit-invokestatic "org/armedbear/lisp/Lisp"
914                                "readObjectFromString"
915                                "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
916                                0))
917           (emit-push-nil) ;; body
918           (emit 'aconst_null) ;; environment
919           (emit-invokespecial super
920                               "<init>"
921                               "(Ljava/lang/String;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/Environment;)V"
922                               -4))
923          (t
924           (emit 'aload_0)
925           (emit-invokespecial super
926                               "<init>"
927                               "()V"
928                               0)))
929    (setf *code* (append *static-code* *code*))
930    (emit 'return)
931    (finalize-code)
932    (optimize-code)
933    (setf (method-max-stack constructor) (analyze-stack))
934    (setf (method-code constructor) (code-bytes *code*))
935    constructor))
936
937(defun write-code-attr (method)
938  (let* ((name-index (pool-name "Code"))
939         (code (method-code method))
940         (code-length (length code))
941         (length (+ code-length 12))
942         (max-stack (or (method-max-stack method) 20))
943         (max-locals (or (method-max-locals method) 1)))
944    (write-u2 name-index)
945    (write-u4 length)
946    (write-u2 max-stack)
947    (write-u2 max-locals)
948    (write-u4 code-length)
949    (dotimes (i code-length)
950      (write-u1 (svref code i)))
951    (write-u2 0) ; exception table length
952    (write-u2 0) ; attributes count
953    ))
954
955(defun write-method (method)
956  (write-u2 (or (method-access-flags method) #x1)) ; access flags
957  (write-u2 (method-name-index method))
958  (write-u2 (method-descriptor-index method))
959  (write-u2 1) ; attributes count
960  (write-code-attr method))
961
962(defun write-field (field)
963  (write-u2 (or (field-access-flags field) #x1)) ; access flags
964  (write-u2 (field-name-index field))
965  (write-u2 (field-descriptor-index field))
966  (write-u2 0)) ; attributes count
967
968(defun declare-field (name descriptor)
969  (let ((field (make-field :name name :descriptor descriptor)))
970    (setf (field-access-flags field) (logior #x8 #x2)) ; private static
971    (setf (field-name-index field) (pool-name (field-name field)))
972    (setf (field-descriptor-index field) (pool-name (field-descriptor field)))
973    (setq *fields* (cons field *fields*))))
974
975(defun sanitize (symbol)
976  (let* ((input (symbol-name symbol))
977         (output (make-array (length input) :fill-pointer 0 :element-type 'character)))
978    (dotimes (i (length input))
979      (let ((c (char-upcase (char input i))))
980        (cond ((<= #.(char-code #\A) (char-code c) #.(char-code #\Z))
981               (vector-push c output))
982              ((eql c #\-)
983               (vector-push #\_ output)))))
984    (when (plusp (length output))
985      output)))
986
987(defvar *declared-symbols* ())
988(defvar *declared-functions* ())
989
990(defun declare-symbol (symbol)
991  (let ((g (gethash symbol *declared-symbols*)))
992    (unless g
993      (let ((*code* *static-code*)
994            (s (sanitize symbol)))
995        (setq g (symbol-name (gensym)))
996        (when s
997          (setq g (concatenate 'string g "_" s)))
998        (declare-field g "Lorg/armedbear/lisp/Symbol;")
999        (emit 'ldc
1000              (pool-string (symbol-name symbol)))
1001        (emit 'ldc
1002              (pool-string (package-name (symbol-package symbol))))
1003        (emit-invokestatic +lisp-class+
1004                           "internInPackage"
1005                           "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
1006                           -1)
1007        (emit 'putstatic
1008              *this-class*
1009              g
1010              "Lorg/armedbear/lisp/Symbol;")
1011        (setq *static-code* *code*)
1012        (setf (gethash symbol *declared-symbols*) g)))
1013    g))
1014
1015(defun declare-function (symbol)
1016  (let ((f (gethash symbol *declared-functions*)))
1017    (unless f
1018      (setf f (symbol-name (gensym)))
1019      (let ((s (sanitize symbol)))
1020        (when s
1021          (setf f (concatenate 'string f "_" s))))
1022      (let ((*code* *static-code*)
1023            (g (gethash symbol *declared-symbols*)))
1024        (cond (g
1025               (emit 'getstatic
1026                     *this-class*
1027                     g
1028                     "Lorg/armedbear/lisp/Symbol;"))
1029              (t
1030               (emit 'ldc
1031                     (pool-string (symbol-name symbol)))
1032               (emit 'ldc
1033                     (pool-string (package-name (symbol-package symbol))))
1034               (emit-invokestatic +lisp-class+
1035                                  "internInPackage"
1036                                  "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
1037                                  -1)))
1038        (declare-field f "Lorg/armedbear/lisp/LispObject;")
1039        (emit-invokevirtual +lisp-symbol-class+
1040                            "getSymbolFunctionOrDie"
1041                            "()Lorg/armedbear/lisp/LispObject;"
1042                            0)
1043        (emit 'putstatic
1044              *this-class*
1045              f
1046              "Lorg/armedbear/lisp/LispObject;")
1047        (setq *static-code* *code*)
1048        (setf (gethash symbol *declared-functions*) f)))
1049    f))
1050
1051(defun declare-keyword (symbol)
1052  (let ((g (symbol-name (gensym)))
1053        (*code* *static-code*))
1054    (declare-field g "Lorg/armedbear/lisp/Symbol;")
1055    (emit 'ldc
1056          (pool-string (symbol-name symbol)))
1057    (emit-invokestatic "org/armedbear/lisp/Keyword"
1058                       "internKeyword"
1059                       "(Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
1060                       0)
1061    (emit 'putstatic
1062          *this-class*
1063          g
1064          "Lorg/armedbear/lisp/Symbol;")
1065    (setq *static-code* *code*)
1066    g))
1067
1068(defun declare-object-as-string (obj)
1069  (let ((g (symbol-name (gensym)))
1070        (s (format nil "~S" obj))
1071        (*code* *static-code*))
1072    (declare-field g +lisp-object+)
1073    (emit 'ldc
1074          (pool-string s))
1075    (emit-invokestatic +lisp-class+
1076                       "readObjectFromString"
1077                       "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
1078                       0)
1079    (emit 'putstatic
1080          *this-class*
1081          g
1082          +lisp-object+)
1083    (setq *static-code* *code*)
1084    g))
1085
1086(defun declare-object (obj)
1087  (let ((key (symbol-name (gensym))))
1088    (sys::remember key obj)
1089    (let* ((g1 (declare-string key))
1090           (g2 (symbol-name (gensym)))
1091           (*code* *static-code*))
1092      (declare-field g2 +lisp-object+)
1093      (emit 'getstatic
1094            *this-class*
1095            g1
1096            +lisp-string+)
1097      (emit 'dup)
1098      (emit-invokestatic +lisp-class+
1099                         "recall"
1100                         "(Lorg/armedbear/lisp/LispString;)Lorg/armedbear/lisp/LispObject;"
1101                         0)
1102      (emit 'putstatic
1103            *this-class*
1104            g2
1105            +lisp-object+)
1106      (emit-invokestatic +lisp-class+
1107                         "forget"
1108                         "(Lorg/armedbear/lisp/LispString;)V"
1109                         -1)
1110      (setq *static-code* *code*)
1111      g2)))
1112
1113(defun declare-string (string)
1114  (let ((g (symbol-name (gensym)))
1115        (*code* *static-code*))
1116    (declare-field g "Lorg/armedbear/lisp/LispString;")
1117    (emit 'ldc
1118          (pool-string string))
1119    (emit-invokestatic "org/armedbear/lisp/LispString"
1120                       "getInstance"
1121                       "(Ljava/lang/String;)Lorg/armedbear/lisp/LispString;"
1122                       0)
1123    (emit 'putstatic
1124          *this-class*
1125          g
1126          +lisp-string+)
1127    (setq *static-code* *code*)
1128    g))
1129
1130(defun compile-constant (form)
1131  (cond
1132   ((sys::fixnump form)
1133    (let ((n form))
1134      (cond ((zerop n)
1135             (emit 'getstatic
1136                   "org/armedbear/lisp/Fixnum"
1137                   "ZERO"
1138                   "Lorg/armedbear/lisp/Fixnum;")
1139             (emit-store-value))
1140            ((= n 1)
1141             (emit 'getstatic
1142                   "org/armedbear/lisp/Fixnum"
1143                   "ONE"
1144                   "Lorg/armedbear/lisp/Fixnum;")
1145             (emit-store-value))
1146            ((= n 2)
1147             (emit 'getstatic
1148                   "org/armedbear/lisp/Fixnum"
1149                   "TWO"
1150                   "Lorg/armedbear/lisp/Fixnum;")
1151             (emit-store-value))
1152            (t
1153             (let ((g (declare-object-as-string n)))
1154               (emit 'getstatic
1155                     *this-class*
1156                     g
1157                     "Lorg/armedbear/lisp/LispObject;")
1158               (emit-store-value))))))
1159   ((numberp form)
1160    (let ((g (declare-object-as-string form)))
1161      (emit 'getstatic
1162            *this-class*
1163            g
1164            "Lorg/armedbear/lisp/LispObject;")
1165      (emit-store-value)))
1166   ((vectorp form)
1167    (let ((g (declare-object-as-string form)))
1168      (emit 'getstatic
1169            *this-class*
1170            g
1171            "Lorg/armedbear/lisp/LispObject;")
1172      (emit-store-value)))
1173   ((stringp form)
1174    (let ((g (declare-string form)))
1175      (emit 'getstatic
1176            *this-class*
1177            g
1178            "Lorg/armedbear/lisp/LispString;")
1179      (emit-store-value)))
1180   ((characterp form)
1181    (let ((g (declare-object-as-string form)))
1182      (emit 'getstatic
1183            *this-class*
1184            g
1185            "Lorg/armedbear/lisp/LispObject;")
1186      (emit-store-value)))
1187   ((symbolp form)
1188    (when (null (symbol-package form))
1189      ;; An uninterned symbol.
1190      (let ((g (declare-object form)))
1191        (emit 'getstatic
1192              *this-class*
1193              g
1194              "Lorg/armedbear/lisp/LispObject;")
1195        (emit-store-value))))
1196   (t
1197    (error "COMPILE-CONSTANT unhandled case ~S" form))))
1198
1199(defun compile-binary-operation (op args)
1200  (compile-form (first args))
1201  (unless (remove-store-value)
1202    (emit-push-value))
1203  (compile-form (second args))
1204  (unless (remove-store-value)
1205    (emit-push-value))
1206  (emit-invokevirtual +lisp-object-class+
1207                      op
1208                      "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1209                      -1)
1210  (emit-store-value))
1211
1212(defparameter unary-operators (make-hash-table))
1213
1214(setf (gethash '1+              unary-operators) "incr")
1215(setf (gethash '1-              unary-operators) "decr")
1216(setf (gethash 'ATOM            unary-operators) "ATOM")
1217(setf (gethash 'BIT-VECTOR-P    unary-operators) "BIT_VECTOR_P")
1218(setf (gethash 'CADR            unary-operators) "cadr")
1219(setf (gethash 'CAR             unary-operators) "car")
1220(setf (gethash 'CDDR            unary-operators) "cddr")
1221(setf (gethash 'CDR             unary-operators) "cdr")
1222(setf (gethash 'COMPLEXP        unary-operators) "COMPLEXP")
1223(setf (gethash 'CONSTANTP       unary-operators) "CONSTANTP")
1224(setf (gethash 'DENOMINATOR     unary-operators) "DENOMINATOR")
1225(setf (gethash 'ENDP            unary-operators) "ENDP")
1226(setf (gethash 'EVENP           unary-operators) "EVENP")
1227(setf (gethash 'FIRST           unary-operators) "car")
1228(setf (gethash 'FLOATP          unary-operators) "FLOATP")
1229(setf (gethash 'INTEGERP        unary-operators) "INTEGERP")
1230(setf (gethash 'LENGTH          unary-operators) "LENGTH")
1231(setf (gethash 'LISTP           unary-operators) "LISTP")
1232(setf (gethash 'MINUSP          unary-operators) "MINUSP")
1233(setf (gethash 'NOT             unary-operators) "NOT")
1234(setf (gethash 'NULL            unary-operators) "NOT")
1235(setf (gethash 'NUMBERP         unary-operators) "NUMBERP")
1236(setf (gethash 'NUMERATOR       unary-operators) "NUMERATOR")
1237(setf (gethash 'ODDP            unary-operators) "ODDP")
1238(setf (gethash 'PLUSP           unary-operators) "PLUSP")
1239(setf (gethash 'RATIONALP       unary-operators) "RATIONALP")
1240(setf (gethash 'REALP           unary-operators) "REALP")
1241(setf (gethash 'REST            unary-operators) "cdr")
1242(setf (gethash 'SECOND          unary-operators) "cadr")
1243(setf (gethash 'SIMPLE-STRING-P unary-operators) "SIMPLE_STRING_P")
1244(setf (gethash 'STRINGP         unary-operators) "STRINGP")
1245(setf (gethash 'SYMBOLP         unary-operators) "SYMBOLP")
1246(setf (gethash 'VECTORP         unary-operators) "VECTORP")
1247(setf (gethash 'ZEROP           unary-operators) "ZEROP")
1248
1249
1250(defun compile-function-call-1 (fun args)
1251  (let ((s (gethash fun unary-operators)))
1252    (when s
1253      (compile-form (first args))
1254      (emit-invoke-method s)
1255      (return-from compile-function-call-1 t)))
1256    nil)
1257
1258(defun compile-function-call-2 (fun args)
1259  (case fun
1260    (EQ
1261     (compile-form (first args))
1262     (unless (remove-store-value)
1263       (emit-push-value))
1264     (compile-form (second args))
1265     (unless (remove-store-value)
1266       (emit-push-value))
1267     (let ((label1 (gensym))
1268           (label2 (gensym)))
1269       (emit 'if_acmpeq `,label1)
1270       (emit-push-nil)
1271       (emit 'goto `,label2)
1272       (emit 'label `,label1)
1273       (emit-push-t)
1274       (emit 'label `,label2))
1275     (emit-store-value)
1276     t)
1277    (EQL
1278     (compile-binary-operation "EQL" args)
1279     t)
1280    (+
1281     (compile-binary-operation "add" args)
1282     t)
1283    (-
1284     (compile-binary-operation "subtract" args)
1285     t)
1286    (/
1287     (compile-binary-operation "divideBy" args)
1288     t)
1289    (*
1290     (compile-binary-operation "multiplyBy" args)
1291     t)
1292    (<
1293     (compile-binary-operation "IS_LT" args)
1294     t)
1295    (<=
1296     (compile-binary-operation "IS_LE" args)
1297     t)
1298    (>
1299     (compile-binary-operation "IS_GT" args)
1300     t)
1301    (>=
1302     (compile-binary-operation "IS_GE" args)
1303     t)
1304    (=
1305     (compile-binary-operation "IS_E" args)
1306     t)
1307    (/=
1308     (compile-binary-operation "IS_NE" args)
1309     t)
1310    (AREF
1311     (compile-binary-operation "AREF" args)
1312     t)
1313    (LIST
1314     (compile-form (first args))
1315     (unless (remove-store-value)
1316       (emit-push-value))
1317     (compile-form (second args))
1318     (unless (remove-store-value)
1319       (emit-push-value))
1320     (emit-invokestatic +lisp-class+
1321                        "list2"
1322                        "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;"
1323                        -1)
1324     (emit-store-value)
1325     t)
1326    (SYS::SIMPLE-TYPEP
1327     (compile-binary-operation "typep" args))
1328    (t
1329     nil)))
1330
1331(defun compile-function-call-3 (fun args)
1332  (case fun
1333    (LIST
1334     (compile-form (first args))
1335     (unless (remove-store-value)
1336       (emit-push-value))
1337     (compile-form (second args))
1338     (unless (remove-store-value)
1339       (emit-push-value))
1340     (compile-form (third args))
1341     (unless (remove-store-value)
1342       (emit-push-value))
1343     (emit-invokestatic +lisp-class+
1344                        "list3"
1345                        "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;"
1346                        -2)
1347     (emit-store-value)
1348     t)
1349    (t
1350     nil)))
1351
1352(defconstant +cl-package+ (find-package "COMMON-LISP"))
1353(defconstant +sys-package+ (find-package "SYSTEM"))
1354
1355(defconstant +known-packages+ (list +cl-package+ +sys-package+))
1356
1357(defun compile-function-call (fun args &optional for-effect)
1358;;   (format t "compile-function-call fun = ~S args = ~S~%" fun args)
1359  (unless (symbolp fun)
1360    (error "COMPILE-FUNCTION-CALL ~S is not a symbol" fun))
1361  (let ((numargs (length args)))
1362    (cond ((= numargs 1)
1363           (when (compile-function-call-1 fun args)
1364             (return-from compile-function-call)))
1365          ((= numargs 2)
1366           (when (compile-function-call-2 fun args)
1367             (return-from compile-function-call)))
1368          ((= numargs 3)
1369           (when (compile-function-call-3 fun args)
1370             (return-from compile-function-call))))
1371
1372    ;; FIXME This shouldn't go here! Do this in the constructor of the
1373    ;; compiled function!
1374    (sys::resolve fun)
1375
1376    (cond
1377     ((eq fun *defun-name*)
1378      (emit 'aload 0)) ; this
1379     ((memq (symbol-package fun) +known-packages+)
1380      (let ((f (declare-function fun)))
1381        (emit 'getstatic
1382              *this-class*
1383              f
1384              "Lorg/armedbear/lisp/LispObject;")))
1385     (t
1386      (let ((g (declare-symbol fun)))
1387        (emit 'getstatic
1388              *this-class*
1389              g
1390              "Lorg/armedbear/lisp/Symbol;"))
1391      (emit-invokevirtual +lisp-symbol-class+
1392                          "getSymbolFunctionOrDie"
1393                          "()Lorg/armedbear/lisp/LispObject;"
1394                          0)))
1395    (case numargs
1396      (0
1397       (emit-invokevirtual +lisp-object-class+
1398                           "execute"
1399                           "()Lorg/armedbear/lisp/LispObject;"
1400                           0))
1401      (1
1402       (compile-form (first args))
1403       (unless (remove-store-value)
1404         (emit-push-value))
1405       (emit-invokevirtual +lisp-object-class+
1406                           "execute"
1407                           "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1408                           -1))
1409      (2
1410       (compile-form (first args))
1411       (unless (remove-store-value)
1412         (emit-push-value))
1413       (compile-form (second args))
1414       (unless (remove-store-value)
1415         (emit-push-value))
1416       (emit-invokevirtual +lisp-object-class+
1417                           "execute"
1418                           "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1419                           -2))
1420      (3
1421       (compile-form (first args))
1422       (unless (remove-store-value)
1423         (emit-push-value))
1424       (compile-form (second args))
1425       (unless (remove-store-value)
1426         (emit-push-value))
1427       (compile-form (third args))
1428       (unless (remove-store-value)
1429         (emit-push-value))
1430       (emit-invokevirtual +lisp-object-class+
1431                           "execute"
1432                           "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1433                           -3))
1434      (t
1435       (emit 'sipush (length args))
1436       (emit 'anewarray "org/armedbear/lisp/LispObject")
1437       (let ((i 0))
1438         (dolist (form args)
1439           (emit 'dup)
1440           (emit 'sipush i)
1441           (compile-form form)
1442           (unless (remove-store-value)
1443             (emit-push-value)) ; leaves value on stack
1444           (emit 'aastore) ; store value in array
1445           (incf i))) ; array left on stack here
1446       ;; Stack: function array-ref
1447       (emit-invokevirtual +lisp-object-class+
1448                           "execute"
1449                           "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1450                           -1)))
1451    (if for-effect
1452        (emit 'pop)
1453        (emit-store-value))))
1454
1455(defun compile-test (form)
1456  ;; Use a Java boolean if possible.
1457  (when (consp form)
1458    (case (length form)
1459      (2 (when (memq (car form) '(NOT NULL))
1460           (compile-form (second form))
1461           (unless (remove-store-value)
1462             (emit-push-value))
1463           (emit-push-nil)
1464           (return-from compile-test 'if_acmpne))
1465         (let ((s (cdr (assoc (car form)
1466                              '((ATOM      . "atom")
1467                                (EVENP     . "evenp")
1468                                (FLOATP    . "floatp")
1469                                (INTEGERP  . "integerp")
1470                                (MINUSP    . "minusp")
1471                                (LISTP     . "listp")
1472                                (NUMBERP   . "numberp")
1473                                (ODDP      . "oddp")
1474                                (PLUSP     . "plusp")
1475                                (RATIONALP . "rationalp")
1476                                (REALP     . "realp")
1477                                (VECTORP   . "vectorp")
1478                                (ZEROP     . "zerop")
1479                                )))))
1480           (when s
1481             (compile-form (second form))
1482             (unless (remove-store-value)
1483               (emit-push-value))
1484             (emit-invokevirtual +lisp-object-class+
1485                                 s
1486                                 "()Z"
1487                                 0)
1488             (return-from compile-test 'ifeq))))
1489      (3 (when (eq (car form) 'EQ)
1490           (compile-form (second form))
1491           (unless (remove-store-value)
1492             (emit-push-value))
1493           (compile-form (third form))
1494           (unless (remove-store-value)
1495             (emit-push-value))
1496           (return-from compile-test 'if_acmpne))
1497         (let ((s (cdr (assoc (car form)
1498                              '((=      . "isEqualTo")
1499                                (/=     . "isNotEqualTo")
1500                                (<      . "isLessThan")
1501                                (<=     . "isLessThanOrEqualTo")
1502                                (>      . "isGreaterThan")
1503                                (>=     . "isGreaterThanOrEqualTo")
1504                                (EQL    . "eql")
1505                                (EQUAL  . "equal")
1506                                (EQUALP . "equalp")
1507                                )))))
1508           (when s
1509             (compile-form (second form))
1510             (unless (remove-store-value)
1511               (emit-push-value))
1512             (compile-form (third form))
1513             (unless (remove-store-value)
1514               (emit-push-value))
1515             (emit-invokevirtual +lisp-object-class+
1516                                 s
1517                                 "(Lorg/armedbear/lisp/LispObject;)Z"
1518                                 -1)
1519             (return-from compile-test 'ifeq))))))
1520  ;; Otherwise...
1521  (compile-form form)
1522  (unless (remove-store-value)
1523    (emit-push-value))
1524  (emit-push-nil)
1525  'if_acmpeq)
1526
1527(defun compile-if (form)
1528  (let* ((test (second form))
1529         (consequent (third form))
1530         (alternate (fourth form))
1531         (label1 (gensym))
1532         (label2 (gensym))
1533         (instr (compile-test test)))
1534    (emit-clear-values)
1535    (emit instr `,label1)
1536    (compile-form consequent)
1537    (emit 'goto `,label2)
1538    (emit 'label `,label1)
1539    (compile-form alternate)
1540    (emit 'label `,label2)))
1541
1542(defun compile-multiple-value-list (form)
1543  (compile-form (second form))
1544  (unless (remove-store-value)
1545    (emit-push-value))
1546  (emit-invokestatic +lisp-class+
1547                     "multipleValueList"
1548                     "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1549                     0)
1550  (emit-store-value))
1551
1552(defun compile-let/let* (form)
1553  (let* ((saved-fp (fill-pointer *locals*))
1554         (varlist (second form))
1555         (specialp nil)
1556         env-var)
1557    ;; Are we going to bind any special variables?
1558    (dolist (varspec varlist)
1559      (let ((var (if (consp varspec) (car varspec) varspec)))
1560        (when (special-variable-p var)
1561          (setq specialp t)
1562          (return))))
1563    ;; If so...
1564    (when specialp
1565      ;; Save current dynamic environment.
1566      (setq env-var (vector-push nil *locals*))
1567      (setq *max-locals* (max *max-locals* (fill-pointer *locals*)))
1568      (ensure-thread-var-initialized)
1569      (emit 'aload *thread*)
1570      (emit-invokevirtual +lisp-thread-class+
1571                          "getDynamicEnvironment"
1572                          "()Lorg/armedbear/lisp/Environment;"
1573                          0)
1574      (emit 'astore env-var))
1575    (ecase (car form)
1576      (LET
1577       (compile-let-vars varlist))
1578      (LET*
1579       (compile-let*-vars varlist)))
1580    ;; Body of LET.
1581    (do ((body (cddr form) (cdr body)))
1582        ((null (cdr body))
1583         (compile-form (car body) nil))
1584      (compile-form (car body) t))
1585    (when specialp
1586      ;; Restore dynamic environment.
1587      (emit 'aload *thread*)
1588      (emit 'aload env-var)
1589      (emit-invokevirtual +lisp-thread-class+
1590                          "setDynamicEnvironment"
1591                          "(Lorg/armedbear/lisp/Environment;)V"
1592                          -2))
1593    ;; Restore fill pointer to its saved value so the slots used by these
1594    ;; bindings will again be available.
1595    (setf (fill-pointer *locals*) saved-fp)))
1596
1597(defun compile-let-vars (varlist)
1598  ;; Generate code to evaluate the initforms and leave the resulting values
1599  ;; on the stack.
1600  (dolist (varspec varlist)
1601    (let (var initform)
1602      (cond ((consp varspec)
1603             (setq var (car varspec)
1604                   initform (cadr varspec)))
1605            (t
1606             (setq var varspec
1607                   initform nil)))
1608      (cond (initform
1609             (compile-form initform)
1610             (emit-push-value))
1611            (t
1612             (emit-push-nil)))))
1613  ;; Add local variables to local variables vector.
1614  (dolist (varspec varlist)
1615    (let ((var (if (consp varspec) (car varspec) varspec)))
1616      (unless (special-variable-p var)
1617        (vector-push var *locals*))))
1618  (setq *max-locals* (max *max-locals* (fill-pointer *locals*)))
1619  ;; At this point the initial values are on the stack. Now generate code to
1620  ;; pop them off one by one and store each one in the corresponding local or
1621  ;; special variable. In order to do this, we must process the variable list
1622  ;; in reverse order.
1623  (do* ((varlist (reverse varlist) (cdr varlist))
1624        (varspec (car varlist) (car varlist))
1625        (var (if (consp varspec) (car varspec) varspec))
1626        (i (1- (fill-pointer *locals*)) (1- i)))
1627       ((null varlist))
1628    (cond ((special-variable-p var)
1629           (let ((g (declare-symbol var)))
1630             (emit 'getstatic
1631                   *this-class*
1632                   g
1633                   "Lorg/armedbear/lisp/Symbol;")
1634             (emit 'swap)
1635             (emit-invokestatic +lisp-class+
1636                                "bindSpecialVariable"
1637                                "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V"
1638                                -2)))
1639          (t
1640           (emit 'astore i)))))
1641
1642(defun compile-let*-vars (varlist)
1643  ;; Generate code to evaluate initforms and bind variables.
1644  (let ((i (fill-pointer *locals*)))
1645    (dolist (varspec varlist)
1646      (let (var initform)
1647        (cond ((consp varspec)
1648               (setq var (car varspec)
1649                     initform (cadr varspec)))
1650              (t
1651               (setq var varspec
1652                     initform nil)))
1653        (cond (initform
1654               (compile-form initform)
1655               (emit-push-value))
1656              (t
1657               (emit-push-nil)))
1658        (cond ((special-variable-p var)
1659               (let ((g (declare-symbol var)))
1660                 (emit 'getstatic
1661                       *this-class*
1662                       g
1663                       "Lorg/armedbear/lisp/Symbol;")
1664                 (emit 'swap)
1665                 (emit-invokestatic +lisp-class+
1666                                    "bindSpecialVariable"
1667                                    "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V"
1668                                    -2)))
1669              (t
1670               (emit 'astore i)
1671               (vector-push var *locals*)
1672               (incf i))))))
1673  (setq *max-locals* (max *max-locals* (fill-pointer *locals*))))
1674
1675(defvar *tags* ())
1676
1677(defstruct tag name label)
1678
1679(defun label-for-tag (name)
1680  (let ((index (position name *tags* :from-end t :key #'tag-name)))
1681;;     (format t "find-tag index = ~S~%" index)
1682    (when index
1683      (tag-label (aref *tags* index)))))
1684
1685(defun compile-tagbody (form)
1686  (let ((saved-fp (fill-pointer *tags*))
1687        (body (cdr form)))
1688    ;; Scan for tags.
1689    (dolist (f body)
1690      (when (atom f)
1691        (let ((name f)
1692              (label (gensym)))
1693          (vector-push (make-tag :name name :label label) *tags*))))
1694    (dolist (f body)
1695      (cond ((atom f)
1696             (let ((label (label-for-tag f)))
1697               (unless label
1698                 (error "COMPILE-TAGBODY: tag not found: ~S" f))
1699               (emit 'label label)))
1700            (t
1701             (compile-form f t))))
1702    (setf (fill-pointer *tags*) saved-fp))
1703  ;; TAGBODY returns NIL.
1704  (emit-push-nil)
1705  (emit-store-value))
1706
1707(defun compile-go (form)
1708  (let* ((name (cadr form))
1709         (label (label-for-tag name)))
1710    (unless label
1711      (error "COMPILE-GO: tag not found: ~S" name))
1712  (emit 'goto label)))
1713
1714(defun compile-block (form)
1715   (let* ((rest (cdr form))
1716          (block-label (car rest))
1717          (block-exit (gensym))
1718          (*blocks* (acons block-label block-exit *blocks*)))
1719     (do* ((forms (cdr rest) (cdr forms)))
1720          ((null forms))
1721       (compile-form (car forms) (cdr forms)))
1722     (emit 'label `,block-exit)))
1723
1724(defun compile-progn (form)
1725  (dolist (form (cdr form))
1726    (compile-form form)))
1727
1728(defun compile-setq (form)
1729  (let* ((rest (cdr form))
1730         (len (length rest))
1731         (sym (car rest))
1732         (index (position sym *locals* :from-end t)))
1733    (unless (= len 2)
1734      (error "COMPILE-SETQ too many args for SETQ"))
1735    (when index
1736      (compile-form (cadr rest))
1737      (emit-push-value)
1738      (emit 'astore index)
1739      (return-from compile-setq))
1740    ;; index is NIL, look in *args* ...
1741    (setq index (position sym *args*))
1742    (when index
1743      (cond (*using-arg-array*
1744             (emit 'aload 1)
1745             (emit 'bipush index)
1746             (compile-form (cadr rest))
1747             (emit-push-value)
1748             (emit 'aastore))
1749            (t
1750             (compile-form (cadr rest))
1751             (emit-push-value)
1752             (emit 'astore (1+ index))))
1753      (return-from compile-setq))
1754    ;; still not found
1755    ;; must be a global variable
1756    (let ((g (declare-symbol sym)))
1757      (emit 'getstatic
1758            *this-class*
1759            g
1760            "Lorg/armedbear/lisp/Symbol;")
1761      (compile-form (cadr rest))
1762      (unless (remove-store-value)
1763        (emit-push-value))
1764      (emit-invokestatic +lisp-class+
1765                         "setSpecialVariable"
1766                         "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1767                         -1)
1768      (emit-store-value))))
1769
1770(defun compile-quote (form)
1771   (let ((obj (second form)))
1772     (cond ((null obj)
1773            (emit-push-nil)
1774            (emit-store-value))
1775           ((symbolp obj)
1776            (if (symbol-package obj)
1777                (let ((g (declare-symbol obj)))
1778                  (emit 'getstatic
1779                        *this-class*
1780                        g
1781                        "Lorg/armedbear/lisp/Symbol;")
1782                  (emit-store-value))
1783                (compile-constant obj)))
1784           ((listp obj)
1785            (let ((g (declare-object-as-string obj)))
1786              (emit 'getstatic
1787                    *this-class*
1788                    g
1789                    +lisp-object+)
1790              (emit-store-value)))
1791           ((constantp obj)
1792            (compile-constant obj))
1793           (t
1794            (error "COMPILE-QUOTE: unsupported case: ~S" form)))))
1795
1796(defun compile-declare (form)
1797  ;; Nothing to do.
1798  )
1799
1800(defun compile-function (form)
1801   (let ((obj (second form)))
1802     (cond ((symbolp obj)
1803            (let ((g (declare-symbol obj)))
1804              (emit 'getstatic
1805                    *this-class*
1806                    g
1807                    "Lorg/armedbear/lisp/Symbol;")
1808              (emit-invokevirtual +lisp-object-class+
1809                                  "getSymbolFunctionOrDie"
1810                                  "()Lorg/armedbear/lisp/LispObject;"
1811                                  0)
1812              (emit-store-value)))
1813           #+nil
1814           ((and (consp obj) (eq (car obj) 'LAMBDA))
1815            ;; FIXME We need to construct a proper lexical environment here
1816            ;; and pass it to coerceToFunction().
1817            (let ((g (declare-object-as-string obj)))
1818              (emit 'getstatic
1819                    *this-class*
1820                    g
1821                    +lisp-object+)
1822              (emit-invokestatic +lisp-class+
1823                                 "coerceToFunction"
1824                                 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Function;"
1825                                 0)
1826              (emit-store-value)))
1827           (t
1828            (error "COMPILE-FUNCTION: unsupported case: ~S" form)))))
1829
1830(defun compile-return-from (form)
1831   (let* ((rest (cdr form))
1832          (block-label (car rest))
1833          (block-exit (cdr (assoc block-label *blocks*)))
1834          (result-form (cadr rest)))
1835     (unless block-exit
1836       (error "no block named ~S is currently visible" block-label))
1837     (compile-form result-form)
1838     (emit 'goto `,block-exit)))
1839
1840(defun compile-plus (form)
1841  (let* ((args (cdr form))
1842         (len (length args)))
1843    (case len
1844      (2
1845       (let ((first (first args))
1846             (second (second args)))
1847         (cond
1848          ((eql first 1)
1849           (compile-form second)
1850           (emit-invoke-method "incr"))
1851          ((eql second 1)
1852           (compile-form first)
1853           (emit-invoke-method "incr"))
1854          (t
1855           (compile-binary-operation "add" args)))))
1856      (t
1857       (compile-function-call '+ args)))))
1858
1859(defun compile-minus (form)
1860  (let* ((args (cdr form))
1861         (len (length args)))
1862    (case len
1863      (2
1864       (let ((first (first args))
1865             (second (second args)))
1866         (cond
1867          ((eql second 1)
1868           (compile-form first)
1869           (emit-invoke-method "decr"))
1870          (t
1871           (compile-binary-operation "subtract" args)))))
1872      (t
1873       (compile-function-call '- args)))))
1874
1875(defun compile-variable-ref (form)
1876  (let ((index (position form *locals* :from-end t)))
1877    (when index
1878      (emit 'aload index)
1879      (emit-store-value)
1880      (return-from compile-variable-ref)))
1881  ;; Not found in locals; look in args.
1882  (let ((index (position form *args*)))
1883    (when index
1884      (cond (*using-arg-array*
1885             (emit 'aload 1)
1886             (emit 'bipush index)
1887             (emit 'aaload)
1888             (emit-store-value)
1889             (return-from compile-variable-ref))
1890            (t
1891             (emit 'aload (1+ index))
1892             (emit-store-value)
1893             (return-from compile-variable-ref)))))
1894
1895  ;; Otherwise it must be a global variable.
1896  (let ((g (declare-symbol form)))
1897    (emit 'getstatic
1898          *this-class*
1899          g
1900          "Lorg/armedbear/lisp/Symbol;")
1901    (emit-invokevirtual +lisp-symbol-class+
1902                        "symbolValue"
1903                        "()Lorg/armedbear/lisp/LispObject;"
1904                        0)
1905    (emit-store-value)
1906    (return-from compile-variable-ref)))
1907
1908;; If for-effect is true, no value needs to be left on the stack.
1909(defun compile-form (form &optional for-effect)
1910  (cond
1911   ((consp form)
1912    (let ((first (first form))
1913          (rest (rest form)))
1914      (when (macro-function first)
1915        (compile-form (macroexpand form))
1916        (return-from compile-form))
1917      (when (symbolp first)
1918        (let ((handler (get first 'jvm-compile)))
1919          (when handler
1920            (funcall handler form)
1921            (return-from compile-form))))
1922      (cond
1923       ((special-operator-p first)
1924        (error "COMPILE-FORM unhandled special operator ~S" first))
1925       (t ; Function call.
1926        (compile-function-call first rest for-effect)))))
1927   ((eq form '())
1928    (unless for-effect
1929      (emit-push-nil)
1930      (emit-store-value)))
1931   ((eq form t)
1932    (unless for-effect
1933      (emit-push-t)
1934      (emit-store-value)))
1935   ((symbolp form)
1936    (when (keywordp form)
1937      (let ((g (declare-keyword form)))
1938        (emit 'getstatic
1939              *this-class*
1940              g
1941              "Lorg/armedbear/lisp/Symbol;"))
1942      (emit-store-value)
1943      (return-from compile-form))
1944
1945    (compile-variable-ref form))
1946   ((constantp form)
1947    (unless for-effect
1948      (compile-constant form)))
1949   (t
1950    (error "COMPILE-FORM unhandled case ~S" form))))
1951
1952;; Returns descriptor.
1953(defun analyze-args (args)
1954  (assert (not (memq '&AUX args)))
1955  (when (or (memq '&KEY args)
1956            (memq '&OPTIONAL args)
1957            (memq '&REST args))
1958    (setq *using-arg-array* t)
1959    (setq *hairy-arglist-p* t)
1960    (return-from analyze-args #.(format nil "([~A)~A" +lisp-object+ +lisp-object+)))
1961  (case (length args)
1962    (0 #.(format nil "()~A" +lisp-object+))
1963    (1 #.(format nil "(~A)~A" +lisp-object+ +lisp-object+))
1964    (2 #.(format nil "(~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+))
1965    (3 #.(format nil "(~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+))
1966    (t (setq *using-arg-array* t)
1967       #.(format nil "([~A)~A" +lisp-object+ +lisp-object+))))
1968
1969(defun compile-defun (name form)
1970  (unless (eq (car form) 'LAMBDA)
1971    (return-from compile-defun nil))
1972  (setq form (transform form))
1973  (let* ((*defun-name* name)
1974         (*declared-symbols* (make-hash-table))
1975         (*declared-functions* (make-hash-table))
1976         (*this-class* "org/armedbear/lisp/out")
1977         (args (cadr form))
1978         (body (cddr form))
1979         (*using-arg-array* nil)
1980         (*hairy-arglist-p* nil)
1981         (descriptor (analyze-args args))
1982         (execute-method (make-method :name "execute"
1983                                      :descriptor descriptor))
1984         (*code* ())
1985         (*static-code* ())
1986         (*fields* ())
1987         (*blocks* ())
1988         (*tags* (make-array 256 :fill-pointer 0)) ; FIXME Remove hard limit!
1989         (*args* (make-array 256 :fill-pointer 0)) ; FIXME Remove hard limit!
1990         (*locals* (make-array 256 :fill-pointer 0)) ; FIXME Remove hard limit!
1991         (*max-locals* 0)
1992         (*pool* ())
1993         (*pool-count* 1)
1994         (*val* nil)
1995         (*thread* nil)
1996         (*thread-var-initialized* nil))
1997    (setf (method-name-index execute-method)
1998          (pool-name (method-name execute-method)))
1999    (setf (method-descriptor-index execute-method)
2000          (pool-name (method-descriptor execute-method)))
2001    (if *hairy-arglist-p*
2002        (let* ((fun (sys::make-compiled-function nil args body))
2003               (vars (sys::varlist fun)))
2004          (dolist (var vars)
2005            (vector-push var *args*)))
2006        (dolist (arg args)
2007          (vector-push arg *args*)))
2008    (if *using-arg-array*
2009        ;; Using arg array: slot 0 is "this" pointer, slot 1 is arg array,
2010        ;; first available slot is 2.
2011        (setf (fill-pointer *locals*) 2)
2012        ;; Not using arg array: slot 0 is "this" pointer, next N slots are used
2013        ;; for args.
2014        (setf (fill-pointer *locals*) (1+ (length args))))
2015    ;; Reserve the next available slot for the value register.
2016    (setq *val* (fill-pointer *locals*))
2017    (incf (fill-pointer *locals*))
2018    (setf *max-locals* (fill-pointer *locals*))
2019    ;; Reserve the next available slot for the thread register.
2020    (setq *thread* (fill-pointer *locals*))
2021    (incf (fill-pointer *locals*))
2022    (setf *max-locals* (fill-pointer *locals*))
2023    (when *hairy-arglist-p*
2024      (emit 'aload_0)
2025      (emit 'aload_1)
2026      (emit-invokevirtual *this-class*
2027                          "processArgs"
2028                          "([Lorg/armedbear/lisp/LispObject;)[Lorg/armedbear/lisp/LispObject;"
2029                          -1)
2030      (emit 'astore_1))
2031    (dolist (f body)
2032      (compile-form f))
2033    (unless (remove-store-value)
2034      (emit-push-value)) ; leave result on stack
2035    (emit 'areturn)
2036    (finalize-code)
2037    (optimize-code)
2038    (setf (method-max-stack execute-method) (analyze-stack))
2039    (setf (method-code execute-method) (code-bytes *code*))
2040;;     (setf (method-max-stack execute-method) *max-stack*)
2041    (setf (method-max-locals execute-method) *max-locals*)
2042
2043    (let* ((super
2044            (if *hairy-arglist-p*
2045                "org.armedbear.lisp.CompiledFunction"
2046                (case (length args)
2047                  (0 "org.armedbear.lisp.Primitive0")
2048                  (1 "org.armedbear.lisp.Primitive1")
2049                  (2 "org.armedbear.lisp.Primitive2")
2050                  (3 "org.armedbear.lisp.Primitive3")
2051                  (t "org.armedbear.lisp.Primitive"))))
2052           (this-index (pool-class *this-class*))
2053           (super-index (pool-class super))
2054           (constructor (make-constructor super *defun-name* args body)))
2055      (pool-name "Code") ; Must be in pool!
2056
2057      ;; Write class file (out.class in current directory).
2058      (with-open-file (*stream* "out.class"
2059                                :direction :output
2060                                :element-type 'unsigned-byte
2061                                :if-exists :supersede)
2062        (write-u4 #xCAFEBABE)
2063        (write-u2 3)
2064        (write-u2 45)
2065        (write-pool)
2066        ;; access flags
2067        (write-u2 #x21)
2068        (write-u2 this-index)
2069        (write-u2 super-index)
2070        ;; interfaces count
2071        (write-u2 0)
2072        ;; fields count
2073        (write-u2 (length *fields*))
2074        ;; fields
2075        (dolist (field *fields*)
2076          (write-field field))
2077        ;; methods count
2078        (write-u2 2)
2079        ;; methods
2080        (write-method execute-method)
2081        (write-method constructor)
2082        ;; attributes count
2083        (write-u2 0))))
2084  (sys::load-compiled-function "out.class"))
2085
2086(defun get-lambda-to-compile (definition-designator)
2087  (if (and (consp definition-designator)
2088           (eq (car definition-designator) 'LAMBDA))
2089      definition-designator
2090      (multiple-value-bind (lambda-expression closure-p)
2091        (function-lambda-expression definition-designator)
2092        (when closure-p
2093          (error "unable to compile function defined in non-null lexical environment"))
2094  (unless lambda-expression
2095    (error "can't find a definition"))
2096        lambda-expression)))
2097
2098(defun load-verbose-prefix ()
2099  (with-output-to-string (s)
2100    (princ #\; s)
2101    (dotimes (i (1- sys::*load-depth*))
2102      (princ #\space s))))
2103
2104(defun jvm-compile (name &optional definition)
2105  (let ((prefix (load-verbose-prefix)))
2106    (when name
2107      (format t "~A Compiling ~S ...~%" prefix name)
2108      (when (and (fboundp name) (typep (fdefinition name) 'generic-function))
2109        (format t "~A Unable to compile generic function ~S~%" prefix name)
2110        (return-from jvm-compile (values name nil t)))
2111      (unless (symbolp name)
2112        (format t "~A Unable to compile ~S~%" prefix name)
2113        (return-from jvm-compile (values name nil t))))
2114    (unless definition
2115      (sys::resolve name)
2116      (setf definition (fdefinition name))
2117      (when (compiled-function-p definition)
2118        (when name
2119          (format t "~A Already compiled ~S~%" prefix name))
2120        (return-from jvm-compile (values name nil nil))))
2121    (handler-case
2122        (let* ((*package* (if (and name (symbol-package name))
2123                              (symbol-package name)
2124                              *package*))
2125               (expr (get-lambda-to-compile definition))
2126               (compiled-definition (compile-defun name expr)))
2127          (when (and name (functionp compiled-definition))
2128            (sys::%set-lambda-name compiled-definition name)
2129            (sys::%set-call-count compiled-definition (sys::%call-count definition))
2130            (sys::%set-arglist compiled-definition (sys::arglist definition))
2131            (if (macro-function name)
2132                (setf (fdefinition name) (sys::make-macro compiled-definition))
2133                (setf (fdefinition name) compiled-definition)))
2134          (when name
2135            (format t "~A Compiled ~S~%" prefix name))
2136          (values (or name compiled-definition) nil nil))
2137      (error (c)
2138             (format t "Error: ~S~%" c)
2139             (when name (format t "~A Unable to compile ~S~%" prefix name))
2140             (values (or name (sys::coerce-to-function definition)) nil t)))))
2141
2142(defun jvm-compile-package (package-designator)
2143  (let ((pkg (if (packagep package-designator)
2144                 package-designator
2145                 (find-package package-designator))))
2146      (dolist (sym (sys::package-symbols pkg))
2147        (when (fboundp sym)
2148          (unless (or (special-operator-p sym) (macro-function sym))
2149            ;; Force autoload to be resolved.
2150            (sys::resolve sym)
2151            (let ((f (fdefinition sym)))
2152              (unless (compiled-function-p f)
2153                (jvm-compile sym)))))))
2154  t)
2155
2156(defun install-handler (fun &optional handler)
2157  (let ((handler (or handler
2158                     (find-symbol (concatenate 'string "COMPILE-" (symbol-name fun)) 'jvm))))
2159    (unless (and handler (fboundp handler))
2160      (error "no handler for ~S" fun))
2161    (setf (get fun 'jvm-compile) handler)))
2162
2163(mapc #'install-handler '(block
2164                          declare
2165                          function
2166                          go
2167                          if
2168                          multiple-value-list
2169                          progn
2170                          quote
2171                          return-from
2172                          setq
2173                          tagbody))
2174
2175(install-handler 'let  'compile-let/let*)
2176(install-handler 'let* 'compile-let/let*)
2177(install-handler '+    'compile-plus)
2178(install-handler '-    'compile-minus)
2179
2180(defun process-optimization-declarations (forms)
2181  (let (alist ())
2182    (dolist (form forms)
2183      (unless (and (consp form) (eq (car form) 'declare))
2184        (return))
2185      (let ((decl (cadr form)))
2186        (when (eq (car decl) 'optimize)
2187          (dolist (spec (cdr decl))
2188            (let ((val 3)
2189                  (quantity spec))
2190              (if (consp spec)
2191                  (setq quantity (car spec) val (cadr spec)))
2192              (if (and (fixnump val) (<= 0 val 3) (memq quantity '(debug speed space safety compilation-speed)))
2193                  (push (cons quantity val) alist)))))))
2194    alist))
2195
2196(defun compile (name &optional definition)
2197  (if (consp name)
2198      (return-from compile (values name nil nil)))
2199  (if (and name (fboundp name) (typep (symbol-function name) 'generic-function))
2200      (return-from compile (values name nil nil)))
2201  (unless definition
2202    (setq definition (or (and (symbolp name) (macro-function name))
2203                         (fdefinition name))))
2204  (let ((expr (get-lambda-to-compile definition))
2205        (speed nil))
2206    (when (eq (car expr) 'lambda)
2207      (let ((decls (process-optimization-declarations (cddr expr))))
2208        (setf speed (cdr (assoc 'speed decls)))))
2209    (if (eql speed 3)
2210        (progn
2211          (c::%compile name definition)
2212          (jvm-compile name definition))
2213        (progn
2214          (c::%compile name definition)
2215          ))))
2216
2217(defmacro defun (name lambda-list &rest body)
2218  `(progn
2219     (sys::%defun ',name ',lambda-list ',body)
2220     (compile ',name)
2221     ',name))
2222
2223(mapc #'jvm-compile '(pool-add
2224                      pool-find-entry
2225                      pool-name
2226                      pool-get
2227                      compile-form))
Note: See TracBrowser for help on using the repository browser.