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

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

COMPILE-LET*-VARS

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