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

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

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