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

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

Work in progress.

File size: 84.3 KB
Line 
1;;; jvm.lisp
2;;;
3;;; Copyright (C) 2003 Peter Graves
4;;; $Id: jvm.lisp,v 1.50 2003-12-04 03:19:22 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 "JVM")
21
22(export '(jvm-compile jvm-compile-package))
23
24(shadow 'method)
25
26(defvar *debug* nil)
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           push-value    store-value  ; 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  `(emit 'store-value))
435
436(defmacro emit-push-value ()
437;;   `(case *val*
438;;      (0
439;;       (emit 'aload_0))
440;;      (1
441;;       (emit 'aload_1))
442;;      (2
443;;       (emit 'aload_2))
444;;      (3
445;;       (emit 'aload_3))
446;;      (t
447;;       (emit 'aload *val*))))
448  `(emit 'push-value))
449
450(defun remove-store-value ()
451;;   (let* ((instruction (car *code*))
452;;          (opcode (instruction-opcode instruction))
453;;          slot)
454;;     (case opcode
455;;       (75
456;;        (setf slot 0))
457;;       (76
458;;        (setf slot 1))
459;;       (77
460;;        (setf slot 2))
461;;       (78
462;;        (setf slot 3))
463;;       (58
464;;        (setf slot (car (instruction-args instruction)))))
465;;     (when (and slot (= slot *val*))
466;;       (setf *code* (cdr *code*))
467;;       t)))
468  (let* ((instruction (car *code*))
469         (opcode (instruction-opcode instruction)))
470;;     (format t "REMOVE-STORE-VALUE called opcode = ~S~%" opcode)
471    (when (eql opcode 204) ; STORE-VALUE
472;;       (format t "removing STORE-VALUE~%")
473      (setf *code* (cdr *code*))
474      t)))
475
476(defconstant +lisp-class+ "org/armedbear/lisp/Lisp")
477(defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject")
478(defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;")
479(defconstant +lisp-string+ "Lorg/armedbear/lisp/LispString;")
480(defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol")
481(defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread")
482(defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons")
483
484(defun emit-push-nil ()
485  (emit 'getstatic
486        +lisp-class+
487        "NIL"
488        +lisp-object+))
489
490(defun emit-push-t ()
491  (emit 'getstatic
492        +lisp-class+
493        "T"
494        "Lorg/armedbear/lisp/Symbol;"))
495
496(defun emit-invokestatic (class-name method-name descriptor stack)
497  (assert stack)
498  (let ((instruction (emit 'invokestatic class-name method-name descriptor)))
499    (setf (instruction-stack instruction) stack)
500    (assert (eql (instruction-stack instruction) stack))))
501
502(defun emit-invokespecial (class-name method-name descriptor stack)
503  (let ((instruction (emit 'invokespecial class-name method-name descriptor)))
504    (setf (instruction-stack instruction) stack)))
505
506(defun emit-invokevirtual (class-name method-name descriptor stack)
507  (let ((instruction (emit 'invokevirtual class-name method-name descriptor)))
508    (setf (instruction-stack instruction) stack)))
509
510;; Index of local variable used to hold the current thread.
511(defvar *thread* nil)
512(defvar *thread-var-initialized* nil)
513
514(defun ensure-thread-var-initialized ()
515  (unless *thread-var-initialized*
516    ;; Put the code to initialize the local at the very beginning of the
517    ;; function, to guarantee that the local gets initialized even if the code
518    ;; at our current location is never executed, since the local may be
519    ;; referenced elsewhere too.
520    (let ((code *code*))
521      (setf *code* ())
522      (emit-invokestatic +lisp-thread-class+
523                         "currentThread"
524                         "()Lorg/armedbear/lisp/LispThread;"
525                         1)
526      (emit 'astore *thread*)
527      (setf *code* (append code *code*)))
528    (setf *thread-var-initialized* t)))
529
530(defun emit-clear-values ()
531  (ensure-thread-var-initialized)
532  (emit 'aload *thread*)
533  (emit-invokevirtual +lisp-thread-class+ "clearValues" "()V" -1))
534
535(defun emit-invoke-method (method-name)
536  (unless (remove-store-value)
537    (emit-push-value))
538  (emit-invokevirtual +lisp-object-class+
539                      method-name
540                      "()Lorg/armedbear/lisp/LispObject;"
541                      0)
542  (emit-store-value))
543
544;; CODE is a list.
545(defun resolve-args (instruction)
546  (let ((opcode (instruction-opcode instruction))
547        (args (instruction-args instruction)))
548    (case opcode
549      (203 ; PUSH-VALUE
550       (case *val*
551         (0
552          (inst 42)) ; ALOAD_0
553         (1
554          (inst 43)) ; ALOAD_1
555         (2
556          (inst 44)) ; ALOAD_2
557         (3
558          (inst 45)) ; ALOAD_3
559         (t
560          (inst 25 *val*))))
561      (204 ; STORE-VALUE
562       (case *val*
563         (0
564          (inst 75)) ; ASTORE_0
565         (1
566          (inst 76)) ; ASTORE_1
567         (2
568          (inst 77)) ; ASTORE_2
569         (3
570          (inst 78)) ; ASTORE_3
571         (t
572          (inst 58 *val*))))
573      ((1 ; ACONST_NULL
574        42 ; ALOAD_0
575        43 ; ALOAD_1
576        44 ; ALOAD_2
577        45 ; ALOAD_3
578        50 ; AALOAD
579        75 ; ASTORE_0
580        76 ; ASTORE_1
581        77 ; ASTORE_2
582        78 ; ASTORE_3
583        83 ; AASTORE
584        87 ; POP
585        89 ; DUP
586        95 ; SWAP
587        153 ; IFEQ
588        154 ; IFNE
589        166 ; IF_ACMPNE
590        165 ; IF_ACMPEQ
591        167 ; GOTO
592        176 ; ARETURN
593        177 ; RETURN
594        202 ; LABEL
595        )
596       instruction)
597      (25 ; ALOAD
598       (let ((index (car args)))
599         (cond ((= index 0)
600                (inst 42)) ; ALOAD_O
601               ((= index 1)
602                (inst 43)) ; ALOAD_1
603               ((= index 2)
604                (inst 44)) ; ALOAD_2
605               ((= index 3)
606                (inst 45)) ; ALOAD_3
607               ((<= 0 index 255)
608                (inst 25 index))
609               (t
610                (error "ALOAD unsupported case")))))
611      (58 ; ASTORE
612       (let ((index (car args)))
613         (cond ((= index 0)
614                (inst 75)) ; ASTORE_O
615               ((= index 1)
616                (inst 76)) ; ASTORE_1
617               ((= index 2)
618                (inst 77)) ; ASTORE_2
619               ((= index 3)
620                (inst 78)) ; ASTORE_3
621               ((<= 0 index 255)
622                (inst 58 index))
623               (t
624                (error "ASTORE unsupported case")))))
625      ((178 ; GETSTATIC class-name field-name type-name
626        179 ; PUTSTATIC class-name field-name type-name
627        )
628       (let ((index (pool-field (first args) (second args) (third args))))
629         (inst opcode (u2 index))))
630      ((182 ; INVOKEVIRTUAL class-name method-name descriptor
631        183 ; INVOKESPECIAL class-name method-name descriptor
632        184 ; INVOKESTATIC class-name method-name descriptor
633        )
634       (let ((index (pool-method (first args) (second args) (third args))))
635;;          (inst opcode (u2 index))))
636         (setf (instruction-args instruction) (u2 index))
637         instruction))
638      ((187 ; NEW class-name
639        189 ; ANEWARRAY class-name
640        193 ; INSTANCEOF class-name
641        )
642       (let ((index (pool-class (first args))))
643         (inst opcode (u2 index))))
644      ((16 ; BIPUSH
645        17 ; SIPUSH
646        )
647       (let ((n (first args)))
648         (cond ((= n 0)
649                (inst 3)) ; ICONST_0
650               ((= n 1)
651                (inst 4)) ; ICONST_1
652               ((= n 2)
653                (inst 5)) ; ICONST_2
654               ((= n 3)
655                (inst 6)) ; ICONST_3
656               ((= n 4)
657                (inst 7)) ; ICONST_4
658               ((= n 5)
659                (inst 8)) ; ICONST_5
660               ((<= -128 n 127)
661                (inst 16 (logand n #xff))) ; BIPUSH
662               (t ; SIPUSH
663                (inst 17 (u2 n))))))
664      (18 ; LDC
665       (unless (= (length args) 1)
666         (error "wrong number of args for LDC"))
667       (if (> (car args) 255)
668           (inst 19 (u2 (car args))) ; LDC_W
669           (inst opcode args)))
670      (t
671       (error "RESOLVE-ARGS unsupported opcode ~D" opcode)))))
672
673;; CODE is a list of INSTRUCTIONs.
674(defun resolve-opcodes (code)
675  (map 'vector #'resolve-args code))
676
677(defun branch-opcode-p (opcode)
678  (member opcode
679    '(153 ; IFEQ
680      154 ; IFNE
681      165 ; IF_ACMPEQ
682      166 ; IF_ACMPNE
683      167 ; GOTO
684      )))
685
686(defun stack-effect (opcode)
687  (case opcode
688    (203 ; PUSH-VALUE
689     1)
690    (204 ; STORE-VALUE
691     -1)
692    ((25 ; ALOAD
693      42 ; ALOAD_0
694      43 ; ALOAD_1
695      44 ; ALOAD_2
696      45 ; ALOAD_3
697      )
698     1)
699    ((58 ; ASTORE
700      75 ; ASTORE_0
701      76 ; ASTORE_1
702      77 ; ASTORE_2
703      78 ; ASTORE_3
704      )
705     -1)
706    (50 ; AALOAD
707     -1)
708    (83 ; AASTORE
709     -3)
710    ((1 ; ACONST_NULL
711      3 4 5 6 7 8 ; ICONST_0 ... ICONST_5
712      16 ; BIPUSH
713      17 ; SIPUSH
714      )
715     1)
716    (18 ; LDC
717     1)
718    (178 ; GETSTATIC
719     1)
720    (179 ; PUTSTATIC
721     -1)
722    (187 ; NEW
723     1)
724    (189 ; ANEWARRAY
725     0)
726    (193 ; INSTANCEOF
727     0)
728    ((153 ; IFEQ
729      154 ; IFNE
730      )
731     -1)
732    ((165 ; IF_ACMPEQ
733      166 ; IF_ACMPNE
734      )
735     -2)
736    ((167 ; GOTO
737      202 ; LABEL
738      )
739     0)
740    (89 ; DUP
741     1)
742    (95 ; SWAP
743     0)
744    (87 ; POP
745     -1)
746    (176 ; ARETURN
747     -1)
748    (177 ; RETURN
749     0)
750    (t
751     (format t "STACK-EFFECT unsupported opcode ~S~%" opcode)
752     0)))
753
754(defun walk-code (code start-index depth)
755  (do* ((i start-index (1+ i))
756        (limit (length code)))
757       ((>= i limit) depth)
758    (let ((instruction (svref code i)))
759      (when (instruction-depth instruction)
760        (return-from walk-code))
761      (setf (instruction-depth instruction) depth)
762      (setf depth (+ depth (instruction-stack instruction)))
763      (if (branch-opcode-p (instruction-opcode instruction))
764          (let ((label (car (instruction-args instruction))))
765;;             (format t "target = ~S~%" target)
766            (walk-code code (symbol-value label) depth)
767            )
768          ()))))
769
770(defun analyze-stack ()
771  (sys::require-type *code* 'vector)
772  (dotimes (i (length *code*))
773    (let* ((instruction (svref *code* i))
774           (opcode (instruction-opcode instruction)))
775      (when (eql opcode 202)
776        (let ((label (car (instruction-args instruction))))
777          (set label i)))
778      (unless (instruction-stack instruction)
779        (setf (instruction-stack instruction) (stack-effect opcode)))))
780  (walk-code *code* 0 0)
781  (let ((max-stack 0))
782    (dotimes (i (length *code*))
783      (let ((instruction (svref *code* i)))
784        (setf max-stack (max max-stack (instruction-depth instruction)))))
785;;     (format t "max-stack = ~D~%" max-stack)
786    max-stack))
787
788(defun finalize-code ()
789  (setf *code* (nreverse (coerce *code* 'vector))))
790
791(defun print-code()
792  (dotimes (i (length *code*))
793    (let ((instruction (svref *code* i)))
794      (format t "~A ~S~%"
795              (instr (instruction-opcode instruction))
796              (instruction-args instruction)))))
797
798(defun validate-labels ()
799  (dotimes (i (length *code*))
800    (let* ((instruction (svref *code* i))
801           (opcode (instruction-opcode instruction)))
802      (when (eql opcode 202)
803        (let ((label (car (instruction-args instruction))))
804          (set label i))))))
805
806(defun optimize-code ()
807  (when *debug*
808    (format t "----- before optimization -----~%")
809    (print-code))
810  (loop
811    (let ((changed-p nil))
812      ;; Make a list of the labels that are actually branched to.
813      (let ((branch-targets ()))
814        (dotimes (i (length *code*))
815          (let ((instruction (svref *code* i)))
816            (when (branch-opcode-p (instruction-opcode instruction))
817              (push (car (instruction-args instruction)) branch-targets))))
818;;         (format t "branch-targets = ~S~%" branch-targets)
819        ;; Remove labels that are not used as branch targets.
820        (dotimes (i (length *code*))
821          (let ((instruction (svref *code* i)))
822            (when (= (instruction-opcode instruction) 202) ; LABEL
823              (let ((label (car (instruction-args instruction))))
824                (unless (member label branch-targets)
825                  (setf (instruction-opcode instruction) 0)'
826                  (setf changed-p t)))))))
827      (setf *code* (delete 0 *code* :key #'instruction-opcode))
828      (dotimes (i (length *code*))
829        (let ((instruction (svref *code* i)))
830          (when (and (< i (1- (length *code*)))
831                     (= (instruction-opcode instruction) 167) ; GOTO
832                     (let ((next-instruction (svref *code* (1+ i))))
833                       (cond ((and (= (instruction-opcode next-instruction) 202) ; LABEL
834                                   (eq (car (instruction-args instruction))
835                                       (car (instruction-args next-instruction))))
836                              ;; GOTO next instruction.
837                              (setf (instruction-opcode instruction) 0)
838                              (setf changed-p t))
839                             ((= (instruction-opcode next-instruction) 167) ; GOTO
840                              ;; One GOTO right after another.
841                              (setf (instruction-opcode next-instruction) 0)
842                              (setf changed-p t))
843                              ))))))
844      (setf *code* (delete 0 *code* :key #'instruction-opcode))
845      ;; Reduce GOTOs.
846      (validate-labels)
847      (dotimes (i (length *code*))
848        (let ((instruction (svref *code* i)))
849          (when (eql (instruction-opcode instruction) 167) ; GOTO
850            (let* ((label (car (instruction-args instruction)))
851                   (target-index (1+ (symbol-value label)))
852                   (instr1 (svref *code* target-index))
853                   (instr2 (if (eql (instruction-opcode instr1) 203) ; PUSH-VALUE
854                               (svref *code* (1+ target-index))
855                               nil)))
856              (when (and instr2 (eql (instruction-opcode instr2) 176)) ; ARETURN
857                (let ((previous-instruction (svref *code* (1- i))))
858                  (when (eql (instruction-opcode previous-instruction) 204) ; STORE-VALUE
859                    (setf (instruction-opcode previous-instruction) 176) ; ARETURN
860                    (setf (instruction-opcode instruction) 0)
861                    (setf changed-p t))))))))
862      (setf *code* (delete 0 *code* :key #'instruction-opcode))
863      ;; Look for sequence STORE-VALUE LOAD-VALUE ARETURN.
864      (dotimes (i (- (length *code*) 2))
865        (let ((instr1 (svref *code* i))
866              (instr2 (svref *code* (+ i 1)))
867              (instr3 (svref *code* (+ i 2))))
868          (when (and (eql (instruction-opcode instr1) 204)
869                     (eql (instruction-opcode instr2) 203)
870                     (eql (instruction-opcode instr3) 176))
871            (setf (instruction-opcode instr1) 176)
872            (setf (instruction-opcode instr2) 0)
873            (setf (instruction-opcode instr3) 0)
874            (setf changed-p t))))
875      (setf *code* (delete 0 *code* :key #'instruction-opcode))
876      (unless changed-p
877          (return))))
878  (when *debug*
879    (format t "----- after optimization -----~%")
880    (print-code)))
881
882(defvar *max-stack*)
883
884;; CODE is a list of INSTRUCTIONs.
885(defun code-bytes (code)
886  (let ((code (resolve-opcodes code))
887        (length 0))
888    ;; Pass 1: calculate label offsets and overall length.
889    (dotimes (i (length code))
890      (let* ((instruction (aref code i))
891             (opcode (instruction-opcode instruction)))
892        (if (= opcode 202) ; LABEL
893            (let ((label (car (instruction-args instruction))))
894              (set label length))
895            (incf length (opcode-size opcode)))))
896    ;; Pass 2: replace labels with calculated offsets.
897    (let ((index 0))
898      (dotimes (i (length code))
899        (let ((instruction (aref code i)))
900          (when (branch-opcode-p (instruction-opcode instruction))
901            (let* ((label (car (instruction-args instruction)))
902                   (offset (- (symbol-value `,label) index)))
903              (setf (instruction-args instruction) (u2 offset))))
904          (unless (= (instruction-opcode instruction) 202) ; LABEL
905            (incf index (opcode-size (instruction-opcode instruction)))))))
906    ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
907    (let ((bytes (make-array length))
908          (index 0))
909      (dotimes (i (length code))
910        (let ((instruction (aref code i)))
911          (unless (= (instruction-opcode instruction) 202) ; LABEL
912            (setf (svref bytes index) (instruction-opcode instruction))
913            (incf index)
914            (dolist (byte (instruction-args instruction))
915              (setf (svref bytes index) byte)
916              (incf index)))))
917      bytes)))
918
919(defun write-u1 (n)
920  (write-byte (logand n #xFF) *stream*))
921
922(defun write-u2 (n)
923  (write-byte (ash n -8) *stream*)
924  (write-byte (logand n #xFF) *stream*))
925
926(defun write-u4 (n)
927  (write-u2 (ash n -16))
928  (write-u2 (logand n #xFFFF)))
929
930(defun write-utf8 (string)
931  (dotimes (i (length string))
932    (let ((c (char string i)))
933      (if (eql c #\null)
934          (progn
935            (write-u1 #xC0)
936            (write-u1 #x80))
937          (write-u1 (char-int c))))))
938
939(defun utf8-length (string)
940  (let ((len 0))
941    (dotimes (i (length string))
942      (incf len (if (eql (char string i) #\null) 2 1)))
943    len))
944
945(defun write-cp-entry (entry)
946  (write-u1 (first entry))
947  (case (first entry)
948    (1 ; UTF8
949     (write-u2 (utf8-length (third entry)))
950     (write-utf8 (third entry)))
951    ((5 6)
952     (write-u4 (second entry))
953     (write-u4 (third entry)))
954    ((9 10 11 12)
955     (write-u2 (second entry))
956     (write-u2 (third entry)))
957    ((7 8)
958     (write-u2 (second entry)))
959    (t
960     (error "WRITE-CP-ENTRY unhandled tag ~D~%" (car entry)))
961  ))
962
963(defun write-pool ()
964  (write-u2 *pool-count*)
965  (dolist (entry (reverse *pool*))
966    (write-cp-entry entry)))
967
968(defstruct field
969  access-flags
970  name
971  descriptor
972  name-index
973  descriptor-index)
974
975(defstruct method
976  access-flags
977  name
978  descriptor
979  name-index
980  descriptor-index
981  max-stack
982  max-locals
983  code)
984
985(defun make-constructor (super name args body)
986  (let* ((constructor (make-method :name "<init>"
987                                   :descriptor "()V"))
988         (*code* ()))
989    (setf (method-name-index constructor) (pool-name (method-name constructor)))
990    (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor)))
991    (setf (method-max-locals constructor) 1)
992    (cond (*hairy-arglist-p*
993           (emit 'aload_0) ;; this
994           (emit 'aconst_null) ;; name
995           (let ((s (format nil "~S" args)))
996             (emit 'ldc
997                   (pool-string s))
998             (emit-invokestatic "org/armedbear/lisp/Lisp"
999                                "readObjectFromString"
1000                                "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
1001                                0))
1002           (emit-push-nil) ;; body
1003           (emit 'aconst_null) ;; environment
1004           (emit-invokespecial super
1005                               "<init>"
1006                               "(Ljava/lang/String;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/Environment;)V"
1007                               -4))
1008          (t
1009           (emit 'aload_0)
1010           (emit-invokespecial super
1011                               "<init>"
1012                               "()V"
1013                               0)))
1014    (setf *code* (append *static-code* *code*))
1015    (emit 'return)
1016    (finalize-code)
1017    (optimize-code)
1018    (setf (method-max-stack constructor) (analyze-stack))
1019    (setf (method-code constructor) (code-bytes *code*))
1020    constructor))
1021
1022(defun write-code-attr (method)
1023  (let* ((name-index (pool-name "Code"))
1024         (code (method-code method))
1025         (code-length (length code))
1026         (length (+ code-length 12))
1027         (max-stack (or (method-max-stack method) 20))
1028         (max-locals (or (method-max-locals method) 1)))
1029    (write-u2 name-index)
1030    (write-u4 length)
1031    (write-u2 max-stack)
1032    (write-u2 max-locals)
1033    (write-u4 code-length)
1034    (dotimes (i code-length)
1035      (write-u1 (svref code i)))
1036    (write-u2 0) ; exception table length
1037    (write-u2 0) ; attributes count
1038    ))
1039
1040(defun write-method (method)
1041  (write-u2 (or (method-access-flags method) #x1)) ; access flags
1042  (write-u2 (method-name-index method))
1043  (write-u2 (method-descriptor-index method))
1044  (write-u2 1) ; attributes count
1045  (write-code-attr method))
1046
1047(defun write-field (field)
1048  (write-u2 (or (field-access-flags field) #x1)) ; access flags
1049  (write-u2 (field-name-index field))
1050  (write-u2 (field-descriptor-index field))
1051  (write-u2 0)) ; attributes count
1052
1053(defun declare-field (name descriptor)
1054  (let ((field (make-field :name name :descriptor descriptor)))
1055    (setf (field-access-flags field) (logior #x8 #x2)) ; private static
1056    (setf (field-name-index field) (pool-name (field-name field)))
1057    (setf (field-descriptor-index field) (pool-name (field-descriptor field)))
1058    (setq *fields* (cons field *fields*))))
1059
1060(defun sanitize (symbol)
1061  (let* ((input (symbol-name symbol))
1062         (output (make-array (length input) :fill-pointer 0 :element-type 'character)))
1063    (dotimes (i (length input))
1064      (let ((c (char-upcase (char input i))))
1065        (cond ((<= #.(char-code #\A) (char-code c) #.(char-code #\Z))
1066               (vector-push c output))
1067              ((eql c #\-)
1068               (vector-push #\_ output)))))
1069    (when (plusp (length output))
1070      output)))
1071
1072(defvar *declared-symbols* ())
1073(defvar *declared-functions* ())
1074
1075(defun declare-symbol (symbol)
1076  (let ((g (gethash symbol *declared-symbols*)))
1077    (unless g
1078      (let ((*code* *static-code*)
1079            (s (sanitize symbol)))
1080        (setq g (symbol-name (gensym)))
1081        (when s
1082          (setq g (concatenate 'string g "_" s)))
1083        (declare-field g "Lorg/armedbear/lisp/Symbol;")
1084        (emit 'ldc
1085              (pool-string (symbol-name symbol)))
1086        (emit 'ldc
1087              (pool-string (package-name (symbol-package symbol))))
1088        (emit-invokestatic +lisp-class+
1089                           "internInPackage"
1090                           "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
1091                           -1)
1092        (emit 'putstatic
1093              *this-class*
1094              g
1095              "Lorg/armedbear/lisp/Symbol;")
1096        (setq *static-code* *code*)
1097        (setf (gethash symbol *declared-symbols*) g)))
1098    g))
1099
1100(defun declare-function (symbol)
1101  (let ((f (gethash symbol *declared-functions*)))
1102    (unless f
1103      (setf f (symbol-name (gensym)))
1104      (let ((s (sanitize symbol)))
1105        (when s
1106          (setf f (concatenate 'string f "_" s))))
1107      (let ((*code* *static-code*)
1108            (g (gethash symbol *declared-symbols*)))
1109        (cond (g
1110               (emit 'getstatic
1111                     *this-class*
1112                     g
1113                     "Lorg/armedbear/lisp/Symbol;"))
1114              (t
1115               (emit 'ldc
1116                     (pool-string (symbol-name symbol)))
1117               (emit 'ldc
1118                     (pool-string (package-name (symbol-package symbol))))
1119               (emit-invokestatic +lisp-class+
1120                                  "internInPackage"
1121                                  "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
1122                                  -1)))
1123        (declare-field f "Lorg/armedbear/lisp/LispObject;")
1124        (emit-invokevirtual +lisp-symbol-class+
1125                            "getSymbolFunctionOrDie"
1126                            "()Lorg/armedbear/lisp/LispObject;"
1127                            0)
1128        (emit 'putstatic
1129              *this-class*
1130              f
1131              "Lorg/armedbear/lisp/LispObject;")
1132        (setq *static-code* *code*)
1133        (setf (gethash symbol *declared-functions*) f)))
1134    f))
1135
1136(defun declare-keyword (symbol)
1137  (let ((g (symbol-name (gensym)))
1138        (*code* *static-code*))
1139    (declare-field g "Lorg/armedbear/lisp/Symbol;")
1140    (emit 'ldc
1141          (pool-string (symbol-name symbol)))
1142    (emit-invokestatic "org/armedbear/lisp/Keyword"
1143                       "internKeyword"
1144                       "(Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;"
1145                       0)
1146    (emit 'putstatic
1147          *this-class*
1148          g
1149          "Lorg/armedbear/lisp/Symbol;")
1150    (setq *static-code* *code*)
1151    g))
1152
1153(defun declare-object-as-string (obj)
1154  (let ((g (symbol-name (gensym)))
1155        (s (format nil "~S" obj))
1156        (*code* *static-code*))
1157    (declare-field g +lisp-object+)
1158    (emit 'ldc
1159          (pool-string s))
1160    (emit-invokestatic +lisp-class+
1161                       "readObjectFromString"
1162                       "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;"
1163                       0)
1164    (emit 'putstatic
1165          *this-class*
1166          g
1167          +lisp-object+)
1168    (setq *static-code* *code*)
1169    g))
1170
1171(defun declare-object (obj)
1172  (let ((key (symbol-name (gensym))))
1173    (sys::remember key obj)
1174    (let* ((g1 (declare-string key))
1175           (g2 (symbol-name (gensym)))
1176           (*code* *static-code*))
1177      (declare-field g2 +lisp-object+)
1178      (emit 'getstatic
1179            *this-class*
1180            g1
1181            +lisp-string+)
1182      (emit 'dup)
1183      (emit-invokestatic +lisp-class+
1184                         "recall"
1185                         "(Lorg/armedbear/lisp/LispString;)Lorg/armedbear/lisp/LispObject;"
1186                         0)
1187      (emit 'putstatic
1188            *this-class*
1189            g2
1190            +lisp-object+)
1191      (emit-invokestatic +lisp-class+
1192                         "forget"
1193                         "(Lorg/armedbear/lisp/LispString;)V"
1194                         -1)
1195      (setq *static-code* *code*)
1196      g2)))
1197
1198(defun declare-string (string)
1199;;   (format t "declare-string string = |~S|~%" string)
1200;;   (when (position #\0 string)
1201;;     (setf string (utf8 string)))
1202  (let ((g (symbol-name (gensym)))
1203        (*code* *static-code*))
1204    (declare-field g "Lorg/armedbear/lisp/LispString;")
1205    (emit 'ldc
1206          (pool-string string))
1207    (emit-invokestatic "org/armedbear/lisp/LispString"
1208                       "getInstance"
1209                       "(Ljava/lang/String;)Lorg/armedbear/lisp/LispString;"
1210                       0)
1211    (emit 'putstatic
1212          *this-class*
1213          g
1214          +lisp-string+)
1215    (setq *static-code* *code*)
1216    g))
1217
1218(defun compile-constant (form)
1219  (cond
1220   ((fixnump form)
1221    (let ((n form))
1222      (cond ((zerop n)
1223             (emit 'getstatic
1224                   "org/armedbear/lisp/Fixnum"
1225                   "ZERO"
1226                   "Lorg/armedbear/lisp/Fixnum;")
1227             (emit-store-value))
1228            ((= n 1)
1229             (emit 'getstatic
1230                   "org/armedbear/lisp/Fixnum"
1231                   "ONE"
1232                   "Lorg/armedbear/lisp/Fixnum;")
1233             (emit-store-value))
1234            ((= n 2)
1235             (emit 'getstatic
1236                   "org/armedbear/lisp/Fixnum"
1237                   "TWO"
1238                   "Lorg/armedbear/lisp/Fixnum;")
1239             (emit-store-value))
1240            (t
1241             (let ((g (declare-object-as-string n)))
1242               (emit 'getstatic
1243                     *this-class*
1244                     g
1245                     "Lorg/armedbear/lisp/LispObject;")
1246               (emit-store-value))))))
1247   ((numberp form)
1248    (let ((g (declare-object-as-string form)))
1249      (emit 'getstatic
1250            *this-class*
1251            g
1252            "Lorg/armedbear/lisp/LispObject;")
1253      (emit-store-value)))
1254   ((stringp form)
1255    (let ((g (declare-string form)))
1256      (emit 'getstatic
1257            *this-class*
1258            g
1259            "Lorg/armedbear/lisp/LispString;")
1260      (emit-store-value)))
1261   ((vectorp form)
1262    (let ((g (declare-object-as-string form)))
1263      (emit 'getstatic
1264            *this-class*
1265            g
1266            "Lorg/armedbear/lisp/LispObject;")
1267      (emit-store-value)))
1268   ((characterp form)
1269    (let ((g (declare-object-as-string form)))
1270      (emit 'getstatic
1271            *this-class*
1272            g
1273            "Lorg/armedbear/lisp/LispObject;")
1274      (emit-store-value)))
1275   ((symbolp form)
1276    (when (null (symbol-package form))
1277      ;; An uninterned symbol.
1278      (let ((g (declare-object form)))
1279        (emit 'getstatic
1280              *this-class*
1281              g
1282              "Lorg/armedbear/lisp/LispObject;")
1283        (emit-store-value))))
1284   (t
1285    (error "COMPILE-CONSTANT unhandled case ~S" form))))
1286
1287(defun compile-binary-operation (op args)
1288  (compile-form (first args))
1289  (unless (remove-store-value)
1290    (emit-push-value))
1291  (compile-form (second args))
1292  (unless (remove-store-value)
1293    (emit-push-value))
1294  (unless (every 'constantp args)
1295    (emit-clear-values))
1296  (emit-invokevirtual +lisp-object-class+
1297                      op
1298                      "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1299                      -1)
1300  (emit-store-value))
1301
1302(defparameter unary-operators (make-hash-table))
1303
1304(setf (gethash '1+              unary-operators) "incr")
1305(setf (gethash '1-              unary-operators) "decr")
1306(setf (gethash 'ATOM            unary-operators) "ATOM")
1307(setf (gethash 'BIT-VECTOR-P    unary-operators) "BIT_VECTOR_P")
1308(setf (gethash 'CADR            unary-operators) "cadr")
1309(setf (gethash 'CAR             unary-operators) "car")
1310(setf (gethash 'CDDR            unary-operators) "cddr")
1311(setf (gethash 'CDR             unary-operators) "cdr")
1312(setf (gethash 'COMPLEXP        unary-operators) "COMPLEXP")
1313(setf (gethash 'CONSTANTP       unary-operators) "CONSTANTP")
1314(setf (gethash 'DENOMINATOR     unary-operators) "DENOMINATOR")
1315(setf (gethash 'ENDP            unary-operators) "ENDP")
1316(setf (gethash 'EVENP           unary-operators) "EVENP")
1317(setf (gethash 'FIRST           unary-operators) "car")
1318(setf (gethash 'FLOATP          unary-operators) "FLOATP")
1319(setf (gethash 'INTEGERP        unary-operators) "INTEGERP")
1320(setf (gethash 'LENGTH          unary-operators) "LENGTH")
1321(setf (gethash 'LISTP           unary-operators) "LISTP")
1322(setf (gethash 'MINUSP          unary-operators) "MINUSP")
1323(setf (gethash 'NOT             unary-operators) "NOT")
1324(setf (gethash 'NREVERSE        unary-operators) "nreverse")
1325(setf (gethash 'NULL            unary-operators) "NOT")
1326(setf (gethash 'NUMBERP         unary-operators) "NUMBERP")
1327(setf (gethash 'NUMERATOR       unary-operators) "NUMERATOR")
1328(setf (gethash 'ODDP            unary-operators) "ODDP")
1329(setf (gethash 'PLUSP           unary-operators) "PLUSP")
1330(setf (gethash 'RATIONALP       unary-operators) "RATIONALP")
1331(setf (gethash 'REALP           unary-operators) "REALP")
1332(setf (gethash 'REST            unary-operators) "cdr")
1333(setf (gethash 'SECOND          unary-operators) "cadr")
1334(setf (gethash 'SIMPLE-STRING-P unary-operators) "SIMPLE_STRING_P")
1335(setf (gethash 'STRINGP         unary-operators) "STRINGP")
1336(setf (gethash 'SYMBOLP         unary-operators) "SYMBOLP")
1337(setf (gethash 'VECTORP         unary-operators) "VECTORP")
1338(setf (gethash 'ZEROP           unary-operators) "ZEROP")
1339
1340(defun compile-function-call-1 (fun args)
1341  (let ((s (gethash fun unary-operators)))
1342    (when s
1343      (compile-form (first args))
1344      (emit-invoke-method s)
1345      (return-from compile-function-call-1 t)))
1346    nil)
1347
1348(defun compile-function-call-2 (fun args)
1349  (case fun
1350    (EQ
1351     (compile-form (first args))
1352     (unless (remove-store-value)
1353       (emit-push-value))
1354     (compile-form (second args))
1355     (unless (remove-store-value)
1356       (emit-push-value))
1357     (let ((label1 (gensym))
1358           (label2 (gensym)))
1359       (emit 'if_acmpeq `,label1)
1360       (emit-push-nil)
1361       (emit 'goto `,label2)
1362       (emit 'label `,label1)
1363       (emit-push-t)
1364       (emit 'label `,label2))
1365     (emit-store-value)
1366     t)
1367    (EQL
1368     (compile-binary-operation "EQL" args)
1369     t)
1370    (+
1371     (compile-binary-operation "add" args)
1372     t)
1373    (-
1374     (compile-binary-operation "subtract" args)
1375     t)
1376    (/
1377     (compile-binary-operation "divideBy" args)
1378     t)
1379    (*
1380     (compile-binary-operation "multiplyBy" args)
1381     t)
1382    (<
1383     (compile-binary-operation "IS_LT" args)
1384     t)
1385    (<=
1386     (compile-binary-operation "IS_LE" args)
1387     t)
1388    (>
1389     (compile-binary-operation "IS_GT" args)
1390     t)
1391    (>=
1392     (compile-binary-operation "IS_GE" args)
1393     t)
1394    (=
1395     (compile-binary-operation "IS_E" args)
1396     t)
1397    (/=
1398     (compile-binary-operation "IS_NE" args)
1399     t)
1400    (AREF
1401     (compile-binary-operation "AREF" args)
1402     t)
1403    (LIST
1404     (compile-form (first args))
1405     (unless (remove-store-value)
1406       (emit-push-value))
1407     (compile-form (second args))
1408     (unless (remove-store-value)
1409       (emit-push-value))
1410     (emit-invokestatic +lisp-class+
1411                        "list2"
1412                        "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;"
1413                        -1)
1414     (emit-store-value)
1415     t)
1416    (SYS::SIMPLE-TYPEP
1417     (compile-binary-operation "typep" args))
1418    (t
1419     nil)))
1420
1421(defun compile-function-call-3 (fun args)
1422  (case fun
1423    (LIST
1424     (compile-form (first args))
1425     (unless (remove-store-value)
1426       (emit-push-value))
1427     (compile-form (second args))
1428     (unless (remove-store-value)
1429       (emit-push-value))
1430     (compile-form (third args))
1431     (unless (remove-store-value)
1432       (emit-push-value))
1433     (unless (every 'constantp args)
1434       (emit-clear-values))
1435     (emit-invokestatic +lisp-class+
1436                        "list3"
1437                        "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;"
1438                        -2)
1439     (emit-store-value)
1440     t)
1441    (t
1442     nil)))
1443
1444(defconstant +known-packages+ (list (find-package "COMMON-LISP")
1445                                    (find-package "SYSTEM")
1446                                    (find-package "EXTENSIONS")))
1447
1448(defun compile-function-call (fun args &optional for-effect)
1449;;   (format t "compile-function-call fun = ~S args = ~S~%" fun args)
1450  (unless (symbolp fun)
1451    (error "COMPILE-FUNCTION-CALL ~S is not a symbol" fun))
1452  (let ((numargs (length args)))
1453    (cond ((= numargs 1)
1454           (when (compile-function-call-1 fun args)
1455             (return-from compile-function-call)))
1456          ((= numargs 2)
1457           (when (compile-function-call-2 fun args)
1458             (return-from compile-function-call)))
1459          ((= numargs 3)
1460           (when (compile-function-call-3 fun args)
1461             (return-from compile-function-call))))
1462
1463    ;; FIXME This shouldn't go here! Do this in the constructor of the
1464    ;; compiled function!
1465    (resolve fun)
1466
1467    (cond
1468     ((eq fun *defun-name*)
1469      (emit 'aload 0)) ; this
1470     ((memq (symbol-package fun) +known-packages+)
1471      (let ((f (declare-function fun)))
1472        (emit 'getstatic
1473              *this-class*
1474              f
1475              "Lorg/armedbear/lisp/LispObject;")))
1476     (t
1477      (let ((g (declare-symbol fun)))
1478        (emit 'getstatic
1479              *this-class*
1480              g
1481              "Lorg/armedbear/lisp/Symbol;"))
1482      (emit-invokevirtual +lisp-symbol-class+
1483                          "getSymbolFunctionOrDie"
1484                          "()Lorg/armedbear/lisp/LispObject;"
1485                          0)))
1486    (case numargs
1487      (0
1488       (emit-invokevirtual +lisp-object-class+
1489                           "execute"
1490                           "()Lorg/armedbear/lisp/LispObject;"
1491                           0))
1492      (1
1493       (compile-form (first args))
1494       (unless (remove-store-value)
1495         (emit-push-value))
1496       (unless (constantp (first args))
1497         (emit-clear-values))
1498       (emit-invokevirtual +lisp-object-class+
1499                           "execute"
1500                           "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1501                           -1))
1502      (2
1503       (compile-form (first args))
1504       (unless (remove-store-value)
1505         (emit-push-value))
1506       (compile-form (second args))
1507       (unless (remove-store-value)
1508         (emit-push-value))
1509       (unless (every 'constantp args)
1510         (emit-clear-values))
1511       (emit-invokevirtual +lisp-object-class+
1512                           "execute"
1513                           "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1514                           -2))
1515      (3
1516       (compile-form (first args))
1517       (unless (remove-store-value)
1518         (emit-push-value))
1519       (compile-form (second args))
1520       (unless (remove-store-value)
1521         (emit-push-value))
1522       (compile-form (third args))
1523       (unless (remove-store-value)
1524         (emit-push-value))
1525       (unless (every 'constantp args)
1526         (emit-clear-values))
1527       (emit-invokevirtual +lisp-object-class+
1528                           "execute"
1529                           "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1530                           -3))
1531      (t
1532       (emit 'sipush (length args))
1533       (emit 'anewarray "org/armedbear/lisp/LispObject")
1534       (let ((i 0))
1535         (dolist (form args)
1536           (emit 'dup)
1537           (emit 'sipush i)
1538           (compile-form form)
1539           (unless (remove-store-value)
1540             (emit-push-value)) ; leaves value on stack
1541           (emit 'aastore) ; store value in array
1542           (incf i))) ; array left on stack here
1543       ;; Stack: function array-ref
1544       (unless (every 'constantp args)
1545         (emit-clear-values))
1546       (emit-invokevirtual +lisp-object-class+
1547                           "execute"
1548                           "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1549                           -1)))
1550    (if for-effect
1551        (emit 'pop)
1552        (emit-store-value))))
1553
1554(defun compile-test (form)
1555  ;; Use a Java boolean if possible.
1556  (when (consp form)
1557    (case (length form)
1558      (2 (when (memq (car form) '(NOT NULL))
1559           (compile-form (second form))
1560           (unless (remove-store-value)
1561             (emit-push-value))
1562           (emit-push-nil)
1563           (return-from compile-test 'if_acmpne))
1564         (when (eq (car form) 'SYMBOLP)
1565           (compile-form (second form))
1566           (unless (remove-store-value)
1567             (emit-push-value))
1568           (emit 'instanceof +lisp-symbol-class+)
1569           (return-from compile-test 'ifeq))
1570         (when (eq (car form) 'CONSP)
1571           (compile-form (second form))
1572           (unless (remove-store-value)
1573             (emit-push-value))
1574           (emit 'instanceof +lisp-cons-class+)
1575           (return-from compile-test 'ifeq))
1576         (when (eq (car form) 'ATOM)
1577           (compile-form (second form))
1578           (unless (remove-store-value)
1579             (emit-push-value))
1580           (emit 'instanceof +lisp-cons-class+)
1581           (return-from compile-test 'ifne))
1582         (let ((s (cdr (assq (car form)
1583                             '((EVENP     . "evenp")
1584                               (FLOATP    . "floatp")
1585                               (INTEGERP  . "integerp")
1586                               (MINUSP    . "minusp")
1587                               (LISTP     . "listp")
1588                               (NUMBERP   . "numberp")
1589                               (ODDP      . "oddp")
1590                               (PLUSP     . "plusp")
1591                               (RATIONALP . "rationalp")
1592                               (REALP     . "realp")
1593                               (VECTORP   . "vectorp")
1594                               (ZEROP     . "zerop")
1595                               )))))
1596           (when s
1597             (compile-form (second form))
1598             (unless (remove-store-value)
1599               (emit-push-value))
1600             (emit-invokevirtual +lisp-object-class+
1601                                 s
1602                                 "()Z"
1603                                 0)
1604             (return-from compile-test 'ifeq))))
1605      (3 (when (eq (car form) 'EQ)
1606           (compile-form (second form))
1607           (unless (remove-store-value)
1608             (emit-push-value))
1609           (compile-form (third form))
1610           (unless (remove-store-value)
1611             (emit-push-value))
1612           (return-from compile-test 'if_acmpne))
1613         (let ((s (cdr (assq (car form)
1614                             '((=      . "isEqualTo")
1615                               (/=     . "isNotEqualTo")
1616                               (<      . "isLessThan")
1617                               (<=     . "isLessThanOrEqualTo")
1618                               (>      . "isGreaterThan")
1619                               (>=     . "isGreaterThanOrEqualTo")
1620                               (EQL    . "eql")
1621                               (EQUAL  . "equal")
1622                               (EQUALP . "equalp")
1623                               )))))
1624           (when s
1625             (compile-form (second form))
1626             (unless (remove-store-value)
1627               (emit-push-value))
1628             (compile-form (third form))
1629             (unless (remove-store-value)
1630               (emit-push-value))
1631             (emit-invokevirtual +lisp-object-class+
1632                                 s
1633                                 "(Lorg/armedbear/lisp/LispObject;)Z"
1634                                 -1)
1635             (return-from compile-test 'ifeq))))))
1636  ;; Otherwise...
1637  (compile-form form)
1638  (unless (remove-store-value)
1639    (emit-push-value))
1640  (unless (atom form) ; FIXME There are other safe cases too!
1641    (emit-clear-values))
1642  (emit-push-nil)
1643  'if_acmpeq)
1644
1645(defun compile-if (form for-effect)
1646  (let* ((test (second form))
1647         (consequent (third form))
1648         (alternate (fourth form))
1649         (label1 (gensym))
1650         (label2 (gensym)))
1651    (emit (compile-test test) `,label1)
1652    (compile-form consequent for-effect)
1653    (emit 'goto `,label2)
1654    (emit 'label `,label1)
1655    (compile-form alternate for-effect)
1656    (emit 'label `,label2)))
1657
1658(defun compile-multiple-value-list (form for-effect)
1659  (compile-form (second form))
1660  (unless (remove-store-value)
1661    (emit-push-value))
1662  (emit-invokestatic +lisp-class+
1663                     "multipleValueList"
1664                     "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1665                     0)
1666  (emit-store-value))
1667
1668(defun compile-let/let* (form for-effect)
1669  (let* ((saved-fp (fill-pointer *locals*))
1670         (varlist (second form))
1671         (specialp nil)
1672         env-var)
1673    ;; Are we going to bind any special variables?
1674    (dolist (varspec varlist)
1675      (let ((var (if (consp varspec) (car varspec) varspec)))
1676        (when (special-variable-p var)
1677          (setq specialp t)
1678          (return))))
1679    ;; If so...
1680    (when specialp
1681      ;; Save current dynamic environment.
1682      (setq env-var (vector-push nil *locals*))
1683      (setq *max-locals* (max *max-locals* (fill-pointer *locals*)))
1684      (ensure-thread-var-initialized)
1685      (emit 'aload *thread*)
1686      (emit-invokevirtual +lisp-thread-class+
1687                          "getDynamicEnvironment"
1688                          "()Lorg/armedbear/lisp/Environment;"
1689                          0)
1690      (emit 'astore env-var))
1691    (ecase (car form)
1692      (LET
1693       (compile-let-vars varlist))
1694      (LET*
1695       (compile-let*-vars varlist)))
1696    ;; Body of LET/LET*.
1697    (do ((body (cddr form) (cdr body)))
1698        ((null (cdr body))
1699         (compile-form (car body) for-effect))
1700      (compile-form (car body) t))
1701    (when specialp
1702      ;; Restore dynamic environment.
1703      (emit 'aload *thread*)
1704      (emit 'aload env-var)
1705      (emit-invokevirtual +lisp-thread-class+
1706                          "setDynamicEnvironment"
1707                          "(Lorg/armedbear/lisp/Environment;)V"
1708                          -2))
1709    ;; Restore fill pointer to its saved value so the slots used by these
1710    ;; bindings will again be available.
1711    (setf (fill-pointer *locals*) saved-fp)))
1712
1713(defun compile-let-vars (varlist)
1714  ;; Generate code to evaluate the initforms and leave the resulting values
1715  ;; on the stack.
1716  (let ((last-push-was-nil nil))
1717    (dolist (varspec varlist)
1718      (let (var initform)
1719        (if (consp varspec)
1720            (setq var (car varspec)
1721                  initform (cadr varspec))
1722            (setq var varspec
1723                  initform nil))
1724        (cond (initform
1725               (compile-form initform)
1726               (unless (remove-store-value)
1727                 (emit-push-value))
1728               (setf last-push-was-nil nil))
1729              (t
1730               (if last-push-was-nil
1731                   (emit 'dup)
1732                   (emit-push-nil))
1733               (setf last-push-was-nil t))))))
1734  ;; Add local variables to local variables vector.
1735  (dolist (varspec varlist)
1736    (let ((var (if (consp varspec) (car varspec) varspec)))
1737      (unless (special-variable-p var)
1738        (vector-push var *locals*))))
1739  (setq *max-locals* (max *max-locals* (fill-pointer *locals*)))
1740  ;; At this point the initial values are on the stack. Now generate code to
1741  ;; pop them off one by one and store each one in the corresponding local or
1742  ;; special variable. In order to do this, we must process the variable list
1743  ;; in reverse order.
1744  (do* ((varlist (reverse varlist) (cdr varlist))
1745        (varspec (car varlist) (car varlist))
1746        (var (if (consp varspec) (car varspec) varspec))
1747        (i (1- (fill-pointer *locals*)) (1- i)))
1748       ((null varlist))
1749    (cond ((special-variable-p var)
1750           (let ((g (declare-symbol var)))
1751             (emit 'getstatic
1752                   *this-class*
1753                   g
1754                   "Lorg/armedbear/lisp/Symbol;")
1755             (emit 'swap)
1756             (emit-invokestatic +lisp-class+
1757                                "bindSpecialVariable"
1758                                "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V"
1759                                -2)))
1760          (t
1761           (emit 'astore i)))))
1762
1763(defun compile-let*-vars (varlist)
1764  ;; Generate code to evaluate initforms and bind variables.
1765  (let ((i (fill-pointer *locals*)))
1766    (dolist (varspec varlist)
1767      (let (var initform)
1768        (if (consp varspec)
1769            (setq var (car varspec)
1770                  initform (cadr varspec))
1771            (setq var varspec
1772                  initform nil))
1773        (cond (initform
1774               (compile-form initform)
1775               (unless (remove-store-value)
1776                 (emit-push-value)))
1777              (t
1778               (emit-push-nil)))
1779        (cond ((special-variable-p var)
1780               (let ((g (declare-symbol var)))
1781                 (emit 'getstatic
1782                       *this-class*
1783                       g
1784                       "Lorg/armedbear/lisp/Symbol;")
1785                 (emit 'swap)
1786                 (emit-invokestatic +lisp-class+
1787                                    "bindSpecialVariable"
1788                                    "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V"
1789                                    -2)))
1790              (t
1791               (emit 'astore i)
1792               (vector-push var *locals*)
1793               (incf i))))))
1794  (setq *max-locals* (max *max-locals* (fill-pointer *locals*))))
1795
1796(defvar *tags* ())
1797
1798(defstruct tag name label)
1799
1800(defun label-for-tag (name)
1801  (let ((index (position name *tags* :from-end t :key #'tag-name)))
1802;;     (format t "find-tag index = ~S~%" index)
1803    (when index
1804      (tag-label (aref *tags* index)))))
1805
1806(defun compile-tagbody (form for-effect)
1807  (let ((saved-fp (fill-pointer *tags*))
1808        (body (cdr form)))
1809    ;; Scan for tags.
1810    (dolist (f body)
1811      (when (atom f)
1812        (let ((name f)
1813              (label (gensym)))
1814          (vector-push (make-tag :name name :label label) *tags*))))
1815    (dolist (f body)
1816      (cond ((atom f)
1817             (let ((label (label-for-tag f)))
1818               (unless label
1819                 (error "COMPILE-TAGBODY: tag not found: ~S" f))
1820               (emit 'label label)))
1821            (t
1822             (compile-form f t))))
1823    (setf (fill-pointer *tags*) saved-fp))
1824  (unless for-effect
1825    ;; TAGBODY returns NIL.
1826    (emit-clear-values)
1827    (emit-push-nil)
1828    (emit-store-value)))
1829
1830(defun compile-go (form for-effect)
1831  (let* ((name (cadr form))
1832         (label (label-for-tag name)))
1833    (unless label
1834      (error "COMPILE-GO: tag not found: ~S" name))
1835  (emit 'goto label)))
1836
1837(defun compile-atom (form for-effect)
1838  (unless (= (length form) 2)
1839    (error "wrong number of arguments for ATOM"))
1840  (compile-form (cadr form) nil)
1841  (unless (remove-store-value)
1842    (emit-push-value))
1843  (emit 'instanceof +lisp-cons-class+)
1844  (let ((label1 (gensym))
1845        (label2 (gensym)))
1846    (emit 'ifeq `,label1)
1847    (emit-push-nil)
1848    (emit 'goto `,label2)
1849    (emit 'label `,label1)
1850    (emit-push-t)
1851    (emit 'label `,label2)
1852    (emit-store-value)))
1853
1854(defun compile-block (form for-effect)
1855  (let* ((rest (cdr form))
1856         (block-label (car rest))
1857         (block-exit (gensym))
1858         (*blocks* (acons block-label block-exit *blocks*)))
1859    (do ((forms (cdr rest) (cdr forms)))
1860        ((null forms))
1861      (compile-form (car forms) (or (cdr forms) for-effect)))
1862    (emit 'label `,block-exit)))
1863
1864(defun compile-cons (form for-effect)
1865  (unless (= (length form) 3)
1866    (error "wrong number of arguments for CONS"))
1867  (emit 'new +lisp-cons-class+)
1868  (emit 'dup)
1869  (compile-form (second form))
1870  (unless (remove-store-value)
1871    (emit-push-value))
1872  (compile-form (third form))
1873  (unless (remove-store-value)
1874    (emit-push-value))
1875  (emit-invokespecial "org/armedbear/lisp/Cons"
1876                      "<init>"
1877                      "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V"
1878                      -3)
1879  (emit-store-value))
1880
1881(defun compile-progn (form for-effect)
1882  (cond ((null (cdr form))
1883         (emit-push-nil)
1884         (emit-store-value))
1885        (t
1886         (do ((forms (cdr form) (cdr forms)))
1887             ((null forms))
1888           (compile-form (car forms) (cdr forms))))))
1889
1890(defun compile-setq (form for-effect)
1891  (unless (= (length form) 3)
1892    (error "COMPILE-SETQ too many args for SETQ"))
1893  (let* ((rest (cdr form))
1894         (sym (car rest))
1895         (index (position sym *locals* :from-end t)))
1896    (when index
1897      (compile-form (cadr rest))
1898      (unless (remove-store-value)
1899        (emit-push-value))
1900      (cond (for-effect
1901             (emit 'astore index))
1902            (t
1903             (emit 'dup)
1904             (emit 'astore index)
1905             (emit-store-value)))
1906      (return-from compile-setq))
1907    ;; index is NIL, look in *args* ...
1908    (setq index (position sym *args*))
1909    (when index
1910      (cond (*using-arg-array*
1911             (emit 'aload 1)
1912             (emit 'bipush index)
1913             (compile-form (cadr rest))
1914             (emit-push-value)
1915             (emit 'aastore))
1916            (t
1917             (compile-form (cadr rest))
1918             (emit-push-value)
1919             (emit 'astore (1+ index))))
1920      (return-from compile-setq))
1921    ;; still not found
1922    ;; must be a global variable
1923    (let ((g (declare-symbol sym)))
1924      (emit 'getstatic
1925            *this-class*
1926            g
1927            "Lorg/armedbear/lisp/Symbol;")
1928      (compile-form (cadr rest))
1929      (unless (remove-store-value)
1930        (emit-push-value))
1931      (emit-invokestatic +lisp-class+
1932                         "setSpecialVariable"
1933                         "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
1934                         -1)
1935      (emit-store-value))))
1936
1937(defun compile-quote (form for-effect)
1938   (let ((obj (second form)))
1939     (cond ((null obj)
1940            (emit-push-nil)
1941            (emit-store-value))
1942           ((symbolp obj)
1943            (if (symbol-package obj)
1944                (let ((g (declare-symbol obj)))
1945                  (emit 'getstatic
1946                        *this-class*
1947                        g
1948                        "Lorg/armedbear/lisp/Symbol;")
1949                  (emit-store-value))
1950                (compile-constant obj)))
1951           ((listp obj)
1952            (let ((g (declare-object-as-string obj)))
1953              (emit 'getstatic
1954                    *this-class*
1955                    g
1956                    +lisp-object+)
1957              (emit-store-value)))
1958           ((constantp obj)
1959            (compile-constant obj))
1960           (t
1961            (error "COMPILE-QUOTE: unsupported case: ~S" form)))))
1962
1963(defun compile-rplacd (form for-effect)
1964  (let ((args (cdr form)))
1965    (unless (= (length args) 2)
1966      (error "wrong number of arguments for RPLACD"))
1967    (compile-form (first args))
1968    (unless (remove-store-value)
1969      (emit-push-value))
1970    (unless for-effect
1971      (emit 'dup))
1972    (compile-form (second args))
1973    (unless (remove-store-value)
1974      (emit-push-value))
1975    (emit-invokevirtual +lisp-object-class+
1976                        "setCdr"
1977                        "(Lorg/armedbear/lisp/LispObject;)V"
1978                        -2)
1979    (unless for-effect
1980      (emit-store-value))))
1981
1982(defun compile-declare (form for-effect)
1983  ;; Nothing to do.
1984  )
1985
1986(defun compile-function (form for-effect)
1987   (let ((obj (second form)))
1988     (cond ((symbolp obj)
1989            (let ((g (declare-symbol obj)))
1990              (emit 'getstatic
1991                    *this-class*
1992                    g
1993                    "Lorg/armedbear/lisp/Symbol;")
1994              (emit-invokevirtual +lisp-object-class+
1995                                  "getSymbolFunctionOrDie"
1996                                  "()Lorg/armedbear/lisp/LispObject;"
1997                                  0)
1998              (emit-store-value)))
1999           #+nil
2000           ((and (consp obj) (eq (car obj) 'LAMBDA))
2001            ;; FIXME We need to construct a proper lexical environment here
2002            ;; and pass it to coerceToFunction().
2003            (let ((g (declare-object-as-string obj)))
2004              (emit 'getstatic
2005                    *this-class*
2006                    g
2007                    +lisp-object+)
2008              (emit-invokestatic +lisp-class+
2009                                 "coerceToFunction"
2010                                 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Function;"
2011                                 0)
2012              (emit-store-value)))
2013           (t
2014            (error "COMPILE-FUNCTION: unsupported case: ~S" form)))))
2015
2016(defun compile-return-from (form for-effect)
2017   (let* ((rest (cdr form))
2018          (block-label (car rest))
2019          (block-exit (cdr (assoc block-label *blocks*)))
2020          (result-form (cadr rest)))
2021     (unless block-exit
2022       (error "no block named ~S is currently visible" block-label))
2023     (compile-form result-form)
2024     (emit 'goto `,block-exit)))
2025
2026(defun compile-plus (form for-effect)
2027  (let* ((args (cdr form))
2028         (len (length args)))
2029    (case len
2030      (2
2031       (let ((first (first args))
2032             (second (second args)))
2033         (cond
2034          ((eql first 1)
2035           (compile-form second)
2036           (emit-invoke-method "incr"))
2037          ((eql second 1)
2038           (compile-form first)
2039           (emit-invoke-method "incr"))
2040          (t
2041           (compile-binary-operation "add" args)))))
2042      (t
2043       (compile-function-call '+ args)))))
2044
2045(defun compile-minus (form for-effect)
2046  (let* ((args (cdr form))
2047         (len (length args)))
2048    (case len
2049      (2
2050       (let ((first (first args))
2051             (second (second args)))
2052         (cond
2053          ((eql second 1)
2054           (compile-form first)
2055           (emit-invoke-method "decr"))
2056          (t
2057           (compile-binary-operation "subtract" args)))))
2058      (t
2059       (compile-function-call '- args)))))
2060
2061(defun compile-values (form for-effect)
2062  (let ((args (cdr form)))
2063    (cond ((= (length args) 2)
2064           (ensure-thread-var-initialized)
2065           (emit 'aload *thread*)
2066           (cond ((and (eq (car args) t)
2067                       (eq (cadr args) t))
2068                  (emit-push-t)
2069                  (emit 'dup))
2070                 ((and (eq (car args) nil)
2071                       (eq (cadr args) nil))
2072                  (emit-push-nil)
2073                  (emit 'dup))
2074                 (t
2075                  (compile-form (car args))
2076                  (unless (remove-store-value)
2077                    (emit-push-value))
2078                  (compile-form (cadr args))
2079                  (unless (remove-store-value)
2080                    (emit-push-value))))
2081           (emit-invokevirtual +lisp-thread-class+
2082                               "setValues"
2083                               "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"
2084                               -2)
2085           (emit-store-value))
2086          (t
2087           (compile-function-call (car form) (cdr form))))))
2088
2089(defun compile-variable-ref (form)
2090  (let ((index (position form *locals* :from-end t)))
2091    (when index
2092      (emit 'aload index)
2093      (emit-store-value)
2094      (return-from compile-variable-ref)))
2095  ;; Not found in locals; look in args.
2096  (let ((index (position form *args*)))
2097    (when index
2098      (cond (*using-arg-array*
2099             (emit 'aload 1)
2100             (emit 'bipush index)
2101             (emit 'aaload)
2102             (emit-store-value)
2103             (return-from compile-variable-ref))
2104            (t
2105             (emit 'aload (1+ index))
2106             (emit-store-value)
2107             (return-from compile-variable-ref)))))
2108
2109  ;; Otherwise it must be a global variable.
2110  (let ((g (declare-symbol form)))
2111    (emit 'getstatic
2112          *this-class*
2113          g
2114          "Lorg/armedbear/lisp/Symbol;")
2115    (emit-invokevirtual +lisp-symbol-class+
2116                        "symbolValue"
2117                        "()Lorg/armedbear/lisp/LispObject;"
2118                        0)
2119    (emit-store-value)
2120    (return-from compile-variable-ref)))
2121
2122;; If for-effect is true, no value needs to be left on the stack.
2123(defun compile-form (form &optional for-effect)
2124  (cond
2125   ((consp form)
2126    (let ((op (car form))
2127          (args (cdr form)))
2128      (when (macro-function op)
2129        (compile-form (macroexpand form))
2130        (return-from compile-form))
2131      (when (symbolp op)
2132        (let ((handler (get op 'jvm-compile-handler)))
2133          (when handler
2134            (funcall handler form for-effect)
2135            (return-from compile-form))))
2136      (cond
2137       ((special-operator-p op)
2138        (error "COMPILE-FORM unsupported special operator ~S" op))
2139       (t ; Function call.
2140        (compile-function-call op args for-effect)))))
2141   ((eq form '())
2142    (unless for-effect
2143      (emit-push-nil)
2144      (emit-store-value)))
2145   ((eq form t)
2146    (unless for-effect
2147      (emit-push-t)
2148      (emit-store-value)))
2149   ((symbolp form)
2150    (when (keywordp form)
2151      (let ((g (declare-keyword form)))
2152        (emit 'getstatic
2153              *this-class*
2154              g
2155              "Lorg/armedbear/lisp/Symbol;"))
2156      (emit-store-value)
2157      (return-from compile-form))
2158
2159    (compile-variable-ref form))
2160   ((constantp form)
2161    (unless for-effect
2162      (compile-constant form)))
2163   (t
2164    (error "COMPILE-FORM unhandled case ~S" form))))
2165
2166;; Returns descriptor.
2167(defun analyze-args (args)
2168  (assert (not (memq '&AUX args)))
2169  (when (or (memq '&KEY args)
2170            (memq '&OPTIONAL args)
2171            (memq '&REST args))
2172    (setq *using-arg-array* t)
2173    (setq *hairy-arglist-p* t)
2174    (return-from analyze-args #.(format nil "([~A)~A" +lisp-object+ +lisp-object+)))
2175  (case (length args)
2176    (0 #.(format nil "()~A" +lisp-object+))
2177    (1 #.(format nil "(~A)~A" +lisp-object+ +lisp-object+))
2178    (2 #.(format nil "(~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+))
2179    (3 #.(format nil "(~A~A~A)~A" +lisp-object+ +lisp-object+ +lisp-object+ +lisp-object+))
2180    (t (setq *using-arg-array* t)
2181       #.(format nil "([~A)~A" +lisp-object+ +lisp-object+))))
2182
2183(defun compile-defun (name form)
2184  (unless (eq (car form) 'LAMBDA)
2185    (return-from compile-defun nil))
2186  (setf form (precompile-form form t))
2187  (let* ((*defun-name* name)
2188         (*declared-symbols* (make-hash-table))
2189         (*declared-functions* (make-hash-table))
2190         (*this-class* "org/armedbear/lisp/out")
2191         (args (cadr form))
2192         (body (cddr form))
2193         (*using-arg-array* nil)
2194         (*hairy-arglist-p* nil)
2195         (descriptor (analyze-args args))
2196         (execute-method (make-method :name "execute"
2197                                      :descriptor descriptor))
2198         (*code* ())
2199         (*static-code* ())
2200         (*fields* ())
2201         (*blocks* ())
2202         (*tags* (make-array 256 :fill-pointer 0)) ; FIXME Remove hard limit!
2203         (*args* (make-array 256 :fill-pointer 0)) ; FIXME Remove hard limit!
2204         (*locals* (make-array 256 :fill-pointer 0)) ; FIXME Remove hard limit!
2205         (*max-locals* 0)
2206         (*pool* ())
2207         (*pool-count* 1)
2208         (*val* nil)
2209         (*thread* nil)
2210         (*thread-var-initialized* nil))
2211    (setf (method-name-index execute-method)
2212          (pool-name (method-name execute-method)))
2213    (setf (method-descriptor-index execute-method)
2214          (pool-name (method-descriptor execute-method)))
2215    (if *hairy-arglist-p*
2216        (let* ((fun (sys::make-compiled-function nil args body))
2217               (vars (sys::varlist fun)))
2218          (dolist (var vars)
2219            (vector-push var *args*)))
2220        (dolist (arg args)
2221          (vector-push arg *args*)))
2222    (if *using-arg-array*
2223        ;; Using arg array: slot 0 is "this" pointer, slot 1 is arg array,
2224        ;; first available slot is 2.
2225        (setf (fill-pointer *locals*) 2)
2226        ;; Not using arg array: slot 0 is "this" pointer, next N slots are used
2227        ;; for args.
2228        (setf (fill-pointer *locals*) (1+ (length args))))
2229    ;; Reserve the next available slot for the value register.
2230    (setq *val* (fill-pointer *locals*))
2231    (incf (fill-pointer *locals*))
2232    (setf *max-locals* (fill-pointer *locals*))
2233    ;; Reserve the next available slot for the thread register.
2234    (setq *thread* (fill-pointer *locals*))
2235    (incf (fill-pointer *locals*))
2236    (setf *max-locals* (fill-pointer *locals*))
2237    (when *hairy-arglist-p*
2238      (emit 'aload_0)
2239      (emit 'aload_1)
2240      (emit-invokevirtual *this-class*
2241                          "processArgs"
2242                          "([Lorg/armedbear/lisp/LispObject;)[Lorg/armedbear/lisp/LispObject;"
2243                          -1)
2244      (emit 'astore_1))
2245    (dolist (f body)
2246      (compile-form f))
2247    (unless (remove-store-value)
2248      (emit-push-value)) ; leave result on stack
2249    (emit 'areturn)
2250    (finalize-code)
2251    (optimize-code)
2252    (setf (method-max-stack execute-method) (analyze-stack))
2253    (setf (method-code execute-method) (code-bytes *code*))
2254;;     (setf (method-max-stack execute-method) *max-stack*)
2255    (setf (method-max-locals execute-method) *max-locals*)
2256
2257    (let* ((super
2258            (if *hairy-arglist-p*
2259                "org.armedbear.lisp.CompiledFunction"
2260                (case (length args)
2261                  (0 "org.armedbear.lisp.Primitive0")
2262                  (1 "org.armedbear.lisp.Primitive1")
2263                  (2 "org.armedbear.lisp.Primitive2")
2264                  (3 "org.armedbear.lisp.Primitive3")
2265                  (t "org.armedbear.lisp.Primitive"))))
2266           (this-index (pool-class *this-class*))
2267           (super-index (pool-class super))
2268           (constructor (make-constructor super *defun-name* args body)))
2269      (pool-name "Code") ; Must be in pool!
2270
2271      ;; Write class file (out.class in current directory).
2272      (with-open-file (*stream* "out.class"
2273                                :direction :output
2274                                :element-type 'unsigned-byte
2275                                :if-exists :supersede)
2276        (write-u4 #xCAFEBABE)
2277        (write-u2 3)
2278        (write-u2 45)
2279        (write-pool)
2280        ;; access flags
2281        (write-u2 #x21)
2282        (write-u2 this-index)
2283        (write-u2 super-index)
2284        ;; interfaces count
2285        (write-u2 0)
2286        ;; fields count
2287        (write-u2 (length *fields*))
2288        ;; fields
2289        (dolist (field *fields*)
2290          (write-field field))
2291        ;; methods count
2292        (write-u2 2)
2293        ;; methods
2294        (write-method execute-method)
2295        (write-method constructor)
2296        ;; attributes count
2297        (write-u2 0))))
2298  (sys::load-compiled-function "out.class"))
2299
2300(defun get-lambda-to-compile (definition-designator)
2301  (if (and (consp definition-designator)
2302           (eq (car definition-designator) 'LAMBDA))
2303      definition-designator
2304      (multiple-value-bind (lambda-expression closure-p)
2305        (function-lambda-expression definition-designator)
2306        (when closure-p
2307          (error "unable to compile function defined in non-null lexical environment"))
2308  (unless lambda-expression
2309    (error "can't find a definition"))
2310        lambda-expression)))
2311
2312(defun load-verbose-prefix ()
2313  (with-output-to-string (s)
2314    (princ #\; s)
2315    (dotimes (i (1- sys::*load-depth*))
2316      (princ #\space s))))
2317
2318(defvar *compile-print* t)
2319
2320(defun jvm-compile (name &optional definition)
2321  (let ((prefix (load-verbose-prefix)))
2322    (when *compile-print*
2323      (if name
2324          (progn
2325            (format t "~A Compiling ~S ...~%" prefix name)
2326            (when (and (fboundp name) (typep (fdefinition name) 'generic-function))
2327              (format t "~A Unable to compile generic function ~S~%" prefix name)
2328              (return-from jvm-compile (values name nil t)))
2329            (unless (symbolp name)
2330              (format t "~A Unable to compile ~S~%" prefix name)
2331              (return-from jvm-compile (values name nil t))))
2332          (format t "~A Compiling top-level form ...~%" prefix)))
2333    (unless definition
2334      (resolve name)
2335      (setf definition (fdefinition name))
2336      (when (compiled-function-p definition)
2337        (when (and *compile-print* name)
2338          (format t "~A Already compiled ~S~%" prefix name))
2339        (return-from jvm-compile (values name nil nil))))
2340    (handler-case
2341        (let* ((*package* (if (and name (symbol-package name))
2342                              (symbol-package name)
2343                              *package*))
2344               (expr (get-lambda-to-compile definition))
2345               (compiled-definition (compile-defun name expr)))
2346          (when (and name (functionp compiled-definition))
2347            (sys::%set-lambda-name compiled-definition name)
2348            (sys::%set-call-count compiled-definition (sys::%call-count definition))
2349            (sys::%set-arglist compiled-definition (sys::arglist definition))
2350            (if (macro-function name)
2351                (setf (fdefinition name) (sys::make-macro compiled-definition))
2352                (setf (fdefinition name) compiled-definition)))
2353          (when *compile-print*
2354            (if name
2355                (format t "~A Compiled ~S~%" prefix name)
2356                (format t "~A Compiled top-level form~%" prefix)))
2357          (values (or name compiled-definition) nil nil))
2358      (error (c)
2359             (format t "Error: ~S~%" c)
2360             (when name
2361               (format t "~A Unable to compile ~S~%" prefix name))
2362             (values (or name (sys::coerce-to-function definition)) nil t)))))
2363
2364(defun jvm-compile-package (package-designator)
2365  (let ((pkg (if (packagep package-designator)
2366                 package-designator
2367                 (find-package package-designator))))
2368      (dolist (sym (sys::package-symbols pkg))
2369        (when (fboundp sym)
2370          (unless (or (special-operator-p sym) (macro-function sym))
2371            ;; Force autoload to be resolved.
2372            (resolve sym)
2373            (let ((f (fdefinition sym)))
2374              (unless (compiled-function-p f)
2375                (jvm-compile sym)))))))
2376  t)
2377
2378(defun install-handler (fun &optional handler)
2379  (let ((handler (or handler
2380                     (find-symbol (concatenate 'string "COMPILE-" (symbol-name fun)) 'jvm))))
2381    (unless (and handler (fboundp handler))
2382      (error "no handler for ~S" fun))
2383    (setf (get fun 'jvm-compile-handler) handler)))
2384
2385(mapc #'install-handler '(atom
2386                          block
2387                          cons
2388                          declare
2389                          function
2390                          go
2391                          if
2392                          multiple-value-list
2393                          progn
2394                          quote
2395                          return-from
2396                          rplacd
2397                          setq
2398                          tagbody
2399                          values))
2400
2401(install-handler 'let  'compile-let/let*)
2402(install-handler 'let* 'compile-let/let*)
2403(install-handler '+    'compile-plus)
2404(install-handler '-    'compile-minus)
2405
2406(defun process-optimization-declarations (forms)
2407  (let (alist ())
2408    (dolist (form forms)
2409      (unless (and (consp form) (eq (car form) 'declare))
2410        (return))
2411      (let ((decl (cadr form)))
2412        (when (eq (car decl) 'optimize)
2413          (dolist (spec (cdr decl))
2414            (let ((val 3)
2415                  (quantity spec))
2416              (if (consp spec)
2417                  (setq quantity (car spec) val (cadr spec)))
2418              (if (and (fixnump val) (<= 0 val 3) (memq quantity '(debug speed space safety compilation-speed)))
2419                  (push (cons quantity val) alist)))))))
2420    alist))
2421
2422(defun compile (name &optional definition)
2423  (if (consp name)
2424      (return-from compile (values name nil nil)))
2425  (if (and name (fboundp name) (typep (symbol-function name) 'generic-function))
2426      (return-from compile (values name nil nil)))
2427  (unless definition
2428    (setq definition (or (and (symbolp name) (macro-function name))
2429                         (fdefinition name))))
2430  (let ((expr (get-lambda-to-compile definition))
2431        (speed nil))
2432    (when (eq (car expr) 'lambda)
2433      (let ((decls (process-optimization-declarations (cddr expr))))
2434        (setf speed (cdr (assoc 'speed decls)))))
2435    (if (or (eql speed 3)
2436            (and (null speed) *auto-compile*))
2437        (progn
2438          (precompile name definition)
2439          (jvm-compile name definition))
2440        (progn
2441          (precompile name definition)
2442          ))))
2443
2444(defmacro defun (name lambda-list &rest body)
2445  `(progn
2446     (sys::%defun ',name ',lambda-list ',body)
2447     (compile ',name)
2448     ',name))
2449
2450(mapc #'jvm-compile '(pool-add
2451                      pool-find-entry
2452                      pool-name
2453                      pool-get
2454                      compile-form))
Note: See TracBrowser for help on using the repository browser.