compiler-pass2.lisp 321 KB
Newer Older
1
;;; compiler-pass2.lisp
2 3
;;;
;;; Copyright (C) 2003-2008 Peter Graves
4
;;; Copyright (C) 2008 Ville Voutilainen
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32
;;; $Id$
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module.  An independent module is a module which is not derived from
;;; or based on this library.  If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so.  If you do not wish to do so, delete this
;;; exception statement from your version.

33
(in-package :jvm)
34 35 36 37 38 39 40 41 42 43

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require "LOOP")
  (require "FORMAT")
  (require "CLOS")
  (require "PRINT-OBJECT")
  (require "COMPILER-TYPES")
  (require "KNOWN-FUNCTIONS")
  (require "KNOWN-SYMBOLS")
  (require "DUMP-FORM")
44
  (require "JVM-INSTRUCTIONS")
45
  (require "JVM-CLASS-FILE")
46 47
  (require "JVM")
  (require "COMPILER-PASS1")
48 49 50
  (require "JAVA"))


51 52 53
(declaim (inline pool-name pool-string pool-name-and-type
                 pool-class pool-field pool-method pool-int
                 pool-float pool-long pool-double))
54

55 56
(declaim (special *memory-class-loader*))

57 58 59 60

(declaim (inline pool-name pool-name-and-type pool-string
                 pool-field pool-method pool-int pool-float pool-long
                 pool-double add-exception-handler))
61
(defun pool-name (name)
62
  (pool-add-utf8 *pool* name))
63 64

(defun pool-name-and-type (name type)
65 66 67 68 69 70 71
  (pool-add-name/type *pool* name type))

(defun pool-class (name)
  (pool-add-class *pool* name))

(defun pool-string (string)
  (pool-add-string *pool* string))
72 73

(defun pool-field (class-name field-name type-name)
74
  (pool-add-field-ref *pool* class-name field-name type-name))
75 76

(defun pool-method (class-name method-name type-name)
77
  (pool-add-method-ref *pool* class-name method-name type-name))
78

79 80
(defun pool-int (int)
  (pool-add-int *pool* int))
81

82 83
(defun pool-float (float)
  (pool-add-float *pool* float))
84

85 86
(defun pool-long (long)
  (pool-add-long *pool* long))
87

88 89 90 91 92 93
(defun pool-double (double)
  (pool-add-double *pool* double))

(defun add-exception-handler (start end handler type)
  (code-add-exception-handler *current-code-attribute*
                              start end handler type))
94

95

96

97 98 99
(defknown emit-push-nil () t)
(declaim (inline emit-push-nil))
(defun emit-push-nil ()
100
  (emit-getstatic +lisp+ "NIL" +lisp-symbol+))
101

102 103 104
(defknown emit-push-nil-symbol () t)
(declaim (inline emit-push-nil-symbol))
(defun emit-push-nil-symbol ()
105
  (emit-getstatic +lisp-nil+ "NIL" +lisp-symbol+))
106

107 108 109
(defknown emit-push-t () t)
(declaim (inline emit-push-t))
(defun emit-push-t ()
110
  (emit-getstatic +lisp+ "T" +lisp-symbol+))
111 112 113 114

(defknown emit-push-false (t) t)
(defun emit-push-false (representation)
  (declare (optimize speed (safety 0)))
115
  (ecase representation
116 117
    (:boolean
     (emit 'iconst_0))
118
    ((nil)
119 120 121 122 123
     (emit-push-nil))))

(defknown emit-push-true (t) t)
(defun emit-push-true (representation)
  (declare (optimize speed (safety 0)))
124
  (ecase representation
125 126
    (:boolean
     (emit 'iconst_1))
127
    ((nil)
128 129 130 131
     (emit-push-t))))

(defknown emit-push-constant-int (fixnum) t)
(defun emit-push-constant-int (n)
132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
  (case n
    (-1
     (emit 'iconst_m1))
    (0
     (emit 'iconst_0))
    (1
     (emit 'iconst_1))
    (2
     (emit 'iconst_2))
    (3
     (emit 'iconst_3))
    (4
     (emit 'iconst_4))
    (5
     (emit 'iconst_5))
    (t
     (if (<= -128 n 127)
         (emit 'bipush n)
         (if (<= -32768 n 32767)
             (emit 'sipush n)
             (emit 'ldc (pool-int n)))))))
153 154 155

(defknown emit-push-constant-long (integer) t)
(defun emit-push-constant-long (n)
156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175
  (case n
    (0 (emit 'lconst_0))
    (1 (emit 'lconst_1))
    (t
     (emit 'ldc2_w (pool-long n)))))

(defknown emit-push-constant-float (single-float) t)
(defun emit-push-constant-float (n)
  (case n
    (0.0s0 (emit 'fconst_0))
    (1.0s0 (emit 'fconst_1))
    (2.0s0 (emit 'fconst_2))
    (t (emit 'ldc (pool-float n)))))

(defknown emit-push-constant-double (double-float) t)
(defun emit-push-constant-double (n)
  (case n
    (0.0d0 (emit 'dconst_0))
    (1.0d0 (emit 'dconst_1))
    (t (emit 'ldc2_w (pool-double n)))))
176

177
(defknown emit-dup (symbol) t)
178 179 180 181 182 183 184 185 186 187 188 189
(defun emit-dup (representation &key (past nil past-supplied-p))
  "Emits the 'dup' instruction required to duplicate `representation'.

If `past' is specified, the newly duplicated value is inserted on the
stack past the top-most value, which is assumed to be of the representation
passed in `past'."
  (emit
   (nth (if past-supplied-p
            (representation-size past) 0)
        (ecase (representation-size representation)
          (1 '(dup  dup_x1  dup_x2))
          (2 '(dup2 dup2_x1 dup2_x2))))))
190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212

(defknown emit-swap (symbol symbol) t)
(defun emit-swap (rep1 rep2)
  "Swaps 2 values on the stack,
the top-most value's representation being 'rep1'."
  (let ((r1-size (representation-size rep1))
        (r2-size (representation-size rep2)))
    (cond ((and (= 1 r1-size)
                (= 1 r2-size))
           (emit 'swap))
          ((and (= 1 r1-size)
                (= 2 r2-size))
           (emit 'dup2_x1)
           (emit 'pop2))
          ((and (= 2 r1-size)
                (= 1 r2-size))
           (emit 'dup_x2)
           (emit 'pop))
          ((and (= 2 r1-size)
                (= 2 r2-size))
           (emit 'dup2_x2)
           (emit 'pop2)))))

213 214
(declaim (ftype (function * t) emit-invokestatic))
(defun emit-invokestatic (class-name method-name arg-types return-type)
215 216 217
  (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types))
         (index (pool-add-method-ref *pool* class-name
                                     method-name (cons return-type arg-types)))
218
         (instruction (%emit 'invokestatic index)))
219 220
    (setf (instruction-stack instruction) stack-effect)))

221 222 223 224


(declaim (ftype (function t string) pretty-java-class))
(defun pretty-java-class (class)
225
  (cond ((equal class +lisp-object+)
226 227 228
         "LispObject")
        ((equal class +lisp-symbol+)
         "Symbol")
229
        ((equal class  +lisp-thread+)
230 231 232 233 234 235
         "LispThread")
        (t
         class)))

(defknown emit-invokevirtual (t t t t) t)
(defun emit-invokevirtual (class-name method-name arg-types return-type)
236 237 238
  (let* ((stack-effect (apply #'descriptor-stack-effect return-type arg-types))
         (index (pool-add-method-ref *pool* class-name
                                     method-name (cons return-type arg-types)))
239
         (instruction (%emit 'invokevirtual index)))
240 241 242 243 244 245 246 247 248 249 250 251 252
    (declare (type (signed-byte 8) stack-effect))
    (let ((explain *explain*))
      (when (and explain (memq :java-calls explain))
        (unless (string= method-name "execute")
          (format t ";   call to ~A ~A.~A(~{~A~^,~})~%"
                  (pretty-java-type return-type)
                  (pretty-java-class class-name)
                  method-name
                  (mapcar 'pretty-java-type arg-types)))))
    (setf (instruction-stack instruction) (1- stack-effect))))

(defknown emit-invokespecial-init (string list) t)
(defun emit-invokespecial-init (class-name arg-types)
253 254 255
  (let* ((stack-effect (apply #'descriptor-stack-effect :void arg-types))
         (index (pool-add-method-ref *pool* class-name
                                     "<init>" (cons nil arg-types)))
256
         (instruction (%emit 'invokespecial index)))
257 258 259 260
    (declare (type (signed-byte 8) stack-effect))
    (setf (instruction-stack instruction) (1- stack-effect))))


261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276
(defknown pretty-java-type (t) string)
(defun pretty-java-type (type)
  (let ((arrayp nil)
        (pretty-string nil))
    (when (and (stringp type)
               (> (length type) 0)
               (char= (char type 0) #\[))
      (setf arrayp t
            type (subseq type 1)))
    (setf pretty-string
          (cond ((equal type +lisp-object+)
                 "LispObject")
                ((equal type +lisp-symbol+)
                 "Symbol")
                ((equal type +lisp-thread+)
                 "LispThread")
277
                ((equal type :char)
278
                 "char")
279
                ((equal type :int)
280
                 "int")
281
                ((equal type :boolean)
282
                 "boolean")
283 284
                ((or (null type)
                     (eq type :void))
285 286 287 288 289 290 291
                 "void")
                (t
                 type)))
    (when arrayp
      (setf pretty-string (concatenate 'string pretty-string "[]")))
    pretty-string))

292 293 294
(declaim (inline emit-getstatic emit-putstatic))
(defknown emit-getstatic (t t t) t)
(defun emit-getstatic (class-name field-name type)
295
  (let ((index (pool-add-field-ref *pool* class-name field-name type)))
296
    (%emit 'getstatic index)))
297 298 299

(defknown emit-putstatic (t t t) t)
(defun emit-putstatic (class-name field-name type)
300
  (let ((index (pool-add-field-ref *pool* class-name field-name type)))
301
    (%emit 'putstatic index)))
302

303 304 305 306
(declaim (inline emit-getfield emit-putfield))
(defknown emit-getfield (t t t) t)
(defun emit-getfield (class-name field-name type)
  (let* ((index (pool-add-field-ref *pool* class-name field-name type)))
307
    (%emit 'getfield index)))
308 309 310 311

(defknown emit-putfield (t t t) t)
(defun emit-putfield (class-name field-name type)
  (let* ((index (pool-add-field-ref *pool* class-name field-name type)))
312
    (%emit 'putfield index)))
313 314 315 316 317


(defknown emit-new (t) t)
(declaim (inline emit-new emit-anewarray emit-checkcast emit-instanceof))
(defun emit-new (class-name)
318
  (%emit 'new (pool-class class-name)))
319 320 321 322 323 324 325

(defknown emit-anewarray (t) t)
(defun emit-anewarray (class-name)
  (apply #'%emit 'anewarray (u2 (pool-class class-name))))

(defknown emit-checkcast (t) t)
(defun emit-checkcast (class-name)
326
  (apply #'%emit 'checkcast (list (pool-class class-name))))
327 328 329

(defknown emit-instanceof (t) t)
(defun emit-instanceof (class-name)
330
  (apply #'%emit 'instanceof (list (pool-class class-name))))
331 332


333 334 335 336 337 338 339 340 341 342 343 344 345
(defvar type-representations '((:int fixnum)
                               (:long (integer #.most-negative-java-long
                                               #.most-positive-java-long))
                               (:float single-float)
                               (:double double-float)
                               (:char base-char character)
                               (:boolean boolean)
                               )
  "Lists the widest Lisp types to be stored in each of the Java primitives
supported (and used) by the compiler.")

(defun type-representation (the-type)
  "Converts a type specification or compiler type into a representation."
346 347
  (when (null the-type)
    (return-from type-representation))
348 349 350 351 352 353 354 355 356
  (do* ((types type-representations (cdr types)))
       ((endp types) nil)
    (do* ((type-list (cdr (car types)) (cdr type-list))
          (type (car type-list) (car type-list)))
         ((endp type-list))
      (when (or (subtypep the-type type)
                (compiler-subtypep the-type (make-compiler-type type)))
        (return-from type-representation (caar types))))))

357 358
(defknown emit-unbox-boolean () t)
(defun emit-unbox-boolean ()
359
  (emit-instanceof +lisp-nil+)
360 361 362 363 364 365
  (emit 'iconst_1)
  (emit 'ixor))  ;; 1 -> 0 && 0 -> 1: in other words, negate the low bit

(defknown emit-unbox-character () t)
(defun emit-unbox-character ()
  (cond ((> *safety* 0)
366 367
         (emit-invokestatic +lisp-character+ "getValue"
                            (lisp-object-arg-types 1) :char))
368
        (t
369 370
         (emit-checkcast +lisp-character+)
         (emit-getfield +lisp-character+ "value" :char))))
371

372 373
;;                     source type /
;;                         targets   :boolean :char    :int :long :float :double
374 375 376 377 378
(defvar rep-conversion `((NIL      . #( ,#'emit-unbox-boolean
                                        ,#'emit-unbox-character
                                       "intValue" "longValue"
                                       "floatValue" "doubleValue"))
                         (:boolean . #( NIL    :err    :err  :err  :err   :err))
379 380 381 382 383 384 385 386 387
                         (:char    . #(  1     NIL     :err  :err  :err   :err))
                         (:int     . #(  1     :err     NIL  i2l   i2f    i2d))
                         (:long    . #(  1     :err     l2i  NIL   l2f    l2d))
                         (:float   . #(  1     :err    :err  :err  NIL    f2d))
                         (:double  . #(  1     :err    :err  :err  d2f    NIL)))
  "Contains a table with operations to be performed to do
internal representation conversion.")

(defvar rep-classes
388 389 390 391 392 393
  `((:boolean . ,+lisp-object+)
    (:char    . ,+lisp-character+)
    (:int     . ,+lisp-integer+)
    (:long    . ,+lisp-integer+)
    (:float   . ,+lisp-single-float+)
    (:double  . ,+lisp-double-float+))
394 395 396 397 398 399 400
  "Lists the class on which to call the `getInstance' method on,
when converting the internal representation to a LispObject.")


(defun convert-representation (in out)
  "Converts the value on the stack in the `in' representation
to a value on the stack in the `out' representation."
401 402 403
  (when (eql in out)
    ;; no-op
    (return-from convert-representation))
404 405 406
  (when (null out)
    ;; Convert back to a lisp object
    (when in
407 408
      (let ((class (cdr (assoc in rep-classes))))
        (emit-invokestatic class "getInstance" (list in) class)))
409 410 411 412 413 414 415
    (return-from convert-representation))
  (let* ((in-map (cdr (assoc in rep-conversion)))
         (op-num (position out '(:boolean :char :int :long :float :double)))
         (op (aref in-map op-num)))
    (when op
      ;; Convert from one internal representation into another
      (assert (neq op :err))
416 417 418 419 420 421
      (cond ((eql op 1)
             (emit-move-from-stack nil in)
             (emit 'iconst_1))
            ((functionp op)
             (funcall op))
            ((stringp op)
422
             (emit-invokevirtual +lisp-object+ op nil out))
423 424
            (t
             (emit op))))))
425

426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447
(defvar common-representations '((:int :long :long)
                                 (:int :float :double)
                                 (:int :double :double)
                                 (:float :int :double)
                                 (:float :double :double)
                                 (:double :int :double)
                                 (:double :float :double))
  "Representations to convert unequal representations to, in order
to get the correct (exact where required) comparisons.")

(defun common-representation (rep1 rep2)
  (when (eq rep1 rep2)
    (return-from common-representation rep1))
  (do* ((remaining common-representations (cdr remaining))
        (rep (car remaining) (car remaining)))
       ((endp remaining))
    (destructuring-bind
          (r1 r2 result) rep
      (when (and (eq rep1 r1) (eq rep2 r2))
        (return-from common-representation result)))))


448 449 450 451 452 453 454
;; Index of local variable used to hold the current thread.
(defvar *thread* nil)

(defvar *initialize-thread-var* nil)

(defun maybe-initialize-thread-var ()
  (when *initialize-thread-var*
455
    (emit-invokestatic +lisp-thread+ "currentThread" nil +lisp-thread+)
456
    (astore *thread*)
457 458 459 460 461 462 463 464 465 466 467
    (setf *initialize-thread-var* nil)))

(defknown ensure-thread-var-initialized () t)
(declaim (inline ensure-thread-var-initialized))
(defun ensure-thread-var-initialized ()
  (setf *initialize-thread-var* t))

(defknown emit-push-current-thread () t)
(defun emit-push-current-thread ()
  (declare (optimize speed))
  (ensure-thread-var-initialized)
468
  (aload *thread*))
469

470
(defun variable-local-p (variable)
471 472 473 474 475 476
  "Return non-NIL if `variable' is a local variable.

Special variables are not considered local."
  (or (variable-register variable) ;; either register or index
      (variable-index variable)))  ;; is non-nil for local variables

477

478 479
(defun emit-load-local-variable (variable)
  "Loads a local variable in the top stack position."
480
  (aver (variable-local-p variable))
481
  (if (variable-register variable)
482
      (aload (variable-register variable))
483
      (progn
484
        (aload (compiland-argument-register *current-compiland*))
485 486 487
        (emit-push-constant-int (variable-index variable))
        (emit 'aaload))))

488
(defun emit-push-variable-name (variable)
489
  (emit-load-externalized-object (variable-name variable)))
490

491 492
(defknown generate-instanceof-type-check-for-variable (t t) t)
(defun generate-instanceof-type-check-for-variable (variable expected-type)
493 494 495 496
  "Generate a type check for `variable'.

The stack pointer is returned to the position from
before the emitted code: the code is 'stack-neutral'."
497
  (declare (type symbol expected-type))
498
  (unless (variable-local-p variable)
499
    (return-from generate-instanceof-type-check-for-variable))
500
  (let ((instanceof-class (ecase expected-type
501 502 503 504 505 506 507 508
                            (SYMBOL     +lisp-symbol+)
                            (CHARACTER  +lisp-character+)
                            (CONS       +lisp-cons+)
                            (HASH-TABLE +lisp-hash-table+)
                            (FIXNUM     +lisp-fixnum+)
                            (STREAM     +lisp-stream+)
                            (STRING     +lisp-abstract-string+)
                            (VECTOR     +lisp-abstract-vector+)))
509 510 511 512
        (expected-type-java-symbol-name (case expected-type
                                          (HASH-TABLE "HASH_TABLE")
                                          (t
                                           (symbol-name expected-type))))
513
        (LABEL1 (gensym)))
514
    (emit-load-local-variable variable)
515
    (emit-instanceof instanceof-class)
516
    (emit 'ifne LABEL1)
517
    (emit-load-local-variable variable)
518
    (emit-getstatic +lisp-symbol+ expected-type-java-symbol-name
519
          +lisp-symbol+)
520
    (emit-invokestatic +lisp+ "type_error"
521
                       (lisp-object-arg-types 2) +lisp-object+)
522
    (emit 'areturn) ; Needed for JVM stack consistency.
523 524 525
    (label LABEL1))
  t)

526 527 528 529 530
(defun find-type-for-type-check (declared-type)
  (if (eq declared-type :none) nil
    (or
     (when (fixnum-type-p declared-type) 'FIXNUM)
     (find-if #'(lambda (type) (eq type declared-type))
531 532 533
              '(SYMBOL CHARACTER CONS HASH-TABLE))
     (find-if #'(lambda (type) (subtypep declared-type type))
              '(STRING VECTOR STREAM)))))
534 535


536 537
(defknown generate-type-check-for-variable (t) t)
(defun generate-type-check-for-variable (variable)
538 539
  (let ((type-to-use
         (find-type-for-type-check (variable-declared-type variable))))
540 541
    (when type-to-use
      (generate-instanceof-type-check-for-variable variable type-to-use))))
542 543 544 545 546

(defknown maybe-generate-type-check (t) t)
(defun maybe-generate-type-check (variable)
  (unless (or (zerop *safety*)
              (variable-special-p variable)
547
              ;###
548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566
              (eq (variable-representation variable) :int))
    (let ((declared-type (variable-declared-type variable)))
      (unless (eq declared-type :none)
        (unless (subtypep (derive-type (variable-initform variable)) declared-type)
          (generate-type-check-for-variable variable))))))

(defknown generate-type-checks-for-variables (list) t)
(defun generate-type-checks-for-variables (variables)
  (unless (zerop *safety*)
    (dolist (variable variables)
      (unless (variable-special-p variable)
        (generate-type-check-for-variable variable)))
    t))

(defun generate-arg-count-check (arity)
  (aver (fixnump arity))
  (aver (not (minusp arity)))
  (aver (not (null (compiland-argument-register *current-compiland*))))
  (let ((label1 (gensym)))
567
    (aload (compiland-argument-register *current-compiland*))
568
    (emit 'arraylength)
569
    (emit-push-constant-int arity)
570
    (emit 'if_icmpeq label1)
571
    (aload 0) ; this
572
    (emit-invokevirtual *this-class* "argCountError" nil nil)
573
    (label label1)))
574 575 576 577

(defun maybe-generate-interrupt-check ()
  (unless (> *speed* *safety*)
    (let ((label1 (gensym)))
578
      (emit-getstatic +lisp+ "interrupted" :boolean)
579
      (emit 'ifeq label1)
580
      (emit-invokestatic +lisp+ "handleInterrupt" nil nil)
581
      (label label1))))
582 583 584

(defknown single-valued-p (t) t)
(defun single-valued-p (form)
585
  (cond ((node-p form)
586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606
         (cond ((tagbody-node-p form)
                t)
               ((block-node-p form)
                (and (single-valued-p (car (last (node-form form))))
                     ;; return-from value forms
                     (every #'single-valued-p
                            (block-return-value-forms form))))
               ((or (flet-node-p form)
                    (labels-node-p form)
                    (let/let*-node-p form)
                    (m-v-b-node-p form)
                    (progv-node-p form)
                    (locally-node-p form)
                    (synchronized-node-p form))
                (single-valued-p (car (last (node-form form)))))
               ((unwind-protect-node-p form)
                (single-valued-p (second (node-form form))))
               ((catch-node-p form)
                nil)
               ((jump-node-p form)
                (single-valued-p (node-form form)))
607 608
               ((exception-protected-node-p form)
                (single-valued-p (exception-protected-form form)))
609 610
               (t
                (assert (not "SINGLE-VALUED-P unhandled NODE-P branch")))))
611 612 613 614 615 616 617 618
        ((var-ref-p form)
         t)
        ((atom form)
         t)
        (t
         (let ((op (%car form))
               result-type
               compiland)
619 620 621 622
           (assert (not (member op '(LET LET* FLET LABELS TAGBODY CATCH
                                         MULTIPLE-VALUE-BIND
                                         UNWIND-PROTECT BLOCK PROGV
                                         LOCALLY))))
623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655
           (cond ((eq op 'IF)
                  (and (single-valued-p (third form))
                       (single-valued-p (fourth form))))
                 ((eq op 'PROGN)
                  (single-valued-p (car (last form))))
                 ((memq op '(AND OR))
                  (every #'single-valued-p (cdr form)))
                 ((eq op 'RETURN-FROM)
                  (single-valued-p (third form)))
                 ((memq op '(THE TRULY-THE))
                  (single-valued-p (third form)))
                 ((setf result-type
                        (or (function-result-type op)
                            (and (proclaimed-ftype op)
                                 (ftype-result-type (proclaimed-ftype op)))))
                  (cond ((eq result-type '*)
                         nil)
                        ((atom result-type)
                         t)
                        ((eq (%car result-type) 'VALUES)
                         (= (length result-type) 2))
                        (t
                         t)))
                 ((and (setf compiland *current-compiland*)
                       (eq op (compiland-name compiland)))
                  (compiland-%single-valued-p compiland))
                 (t
                  nil))))))

(defknown emit-clear-values () t)
(defun emit-clear-values ()
  (declare (optimize speed (safety 0)))
  (ensure-thread-var-initialized)
656
  (emit 'clear-values *thread*))
657 658 659 660 661 662 663

(defknown maybe-emit-clear-values (&rest t) t)
(defun maybe-emit-clear-values (&rest forms)
  (declare (optimize speed))
  (dolist (form forms)
    (unless (single-valued-p form)
      (ensure-thread-var-initialized)
664
      (emit 'clear-values *thread*)
665 666
      (return))))

667 668
(defun compile-forms-and-maybe-emit-clear-values (&rest forms-and-compile-args)
  (let ((forms-for-emit-clear
669 670 671
         (loop for (form arg1 arg2) on forms-and-compile-args by #'cdddr
            do (compile-form form arg1 arg2)
            collecting form)))
672
    (apply #'maybe-emit-clear-values forms-for-emit-clear)))
673

674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793

(declaim (special *saved-operands* *operand-representations*))
(defmacro with-operand-accumulation ((&body argument-accumulation-body)
                                     &body call-body)
  "Macro used to operand-stack-safely collect arguments in the
`argument-accumulation-body' to be available on the stack upon entry of the
`call-body'. The argument-accumulation-body code may not assume arguments
are actually on the stack while accumulating.

This macro closes over a code-generating block. Operands can be collected
using the `accumulate-operand', `compile-operand', `emit-variable-operand'
and `emit-load-externalized-object-operand'."
  `(let (*saved-operands*
         *operand-representations*
         (*register* *register*)
         ) ;; hmm can we do this?? either body
                                  ;; could allocate registers ...
     ,@argument-accumulation-body
     (load-saved-operands)
     ,@call-body))

(defmacro accumulate-operand ((representation &key unsafe-p)
                              &body body)
  "Macro used to collect a single operand.

This macro closes over a code-generating block. The generated code should
leave a single operand on the stack, with representation `representation'.
The value `unsafe-p', when provided, is an expression evaluated at run time
to indicate if the body is opstack unsafe."
  `(progn
     ,@(when unsafe-p
         `((when ,unsafe-p
             (save-existing-operands))))
     ,@body
     (save-operand ,representation)))

(defun load-saved-operands ()
  "Load any operands which have been saved into registers
back onto the stack in preparation of the execution of the opcode."
  (mapcar #'emit-push-register
          (reverse *saved-operands*)
          (reverse *operand-representations*)))

(defun save-existing-operands ()
  "If any operands have been compiled to the stack,
save them in registers."
  (when (null *saved-operands*)
    (dolist (representation *operand-representations*)
      (let ((register (allocate-register representation)))
        (push register *saved-operands*)
        (emit-move-from-stack register representation)))

    (setf *saved-operands* (nreverse *saved-operands*))))

(defun save-operand (representation)
  "Saves an operand from the stack (with `representation') to
a register and updates associated operand collection variables."
  (push representation *operand-representations*)

  (when *saved-operands*
    (let ((register (allocate-register representation)))
      (push register *saved-operands*)
      (emit-move-from-stack register representation))))

(defun compile-operand (form representation &optional cast)
  "Compiles `form' into `representation', storing the resulting value
on the operand stack, if it's safe to do so. Otherwise stores the value
in a register"
  (let ((unsafe (or *saved-operands*
                    (some-nested-block #'node-opstack-unsafe-p
                                       (find-enclosed-blocks form)))))
    (when (and unsafe (null *saved-operands*))
      (save-existing-operands))

    (compile-form form 'stack representation)
    (when cast
      (emit-checkcast cast))
    (when unsafe
      (let ((register (allocate-register representation)))
        (push register *saved-operands*)
        (emit-move-from-stack register representation)))

  (push representation *operand-representations*)))

(defun emit-variable-operand (variable)
  "Pushes a variable onto the operand stack, if it's safe to do so. Otherwise
stores the value in a register."
  (push (variable-representation variable) *operand-representations*)
  (cond
   ((and *saved-operands*
         (variable-register variable))
    ;; we're in 'safe mode' and the  variable is in a register,
    ;; instead of binding a new register, just load the existing one
    (push (variable-register variable) *saved-operands*))
   (t
    (emit-push-variable variable)
    (when *saved-operands* ;; safe-mode
      (let ((register (allocate-register (variable-representation variable))))
        (push register *saved-operands*)
        (emit-move-from-stack register (variable-representation variable)))))))

(defun emit-register-operand (register representation)
  (push representation *operand-representations*)
  (cond (*saved-operands*
         (push register *saved-operands*))
        (t
         (emit-push-register register representation))))

(defun emit-thread-operand ()
  (ensure-thread-var-initialized)
  (emit-register-operand *thread* nil))

(defun emit-load-externalized-object-operand (object)
  (push nil *operand-representations*)
  (emit-load-externalized-object object)
  (when *saved-operands* ;; safe-mode
    (let ((register (allocate-register nil)))
      (push register *saved-operands*)
      (emit 'astore register))))

794 795 796 797
(defknown emit-unbox-fixnum () t)
(defun emit-unbox-fixnum ()
  (declare (optimize speed))
  (cond ((= *safety* 3)
798 799
         (emit-invokestatic +lisp-fixnum+ "getValue"
                            (lisp-object-arg-types 1) :int))
800
        (t
801 802
         (emit-checkcast +lisp-fixnum+)
         (emit-getfield +lisp-fixnum+ "value" :int))))
803

804 805
(defknown emit-unbox-long () t)
(defun emit-unbox-long ()
806 807
  (emit-invokestatic +lisp-bignum+ "longValue"
                     (lisp-object-arg-types 1) :long))
808 809 810 811 812

(defknown emit-unbox-float () t)
(defun emit-unbox-float ()
  (declare (optimize speed))
  (cond ((= *safety* 3)
813 814
         (emit-invokestatic +lisp-single-float+ "getValue"
                            (lisp-object-arg-types 1) :float))
815
        (t
816 817
         (emit-checkcast +lisp-single-float+)
         (emit-getfield +lisp-single-float+ "value" :float))))
818 819 820 821 822

(defknown emit-unbox-double () t)
(defun emit-unbox-double ()
  (declare (optimize speed))
  (cond ((= *safety* 3)
823 824
         (emit-invokestatic +lisp-double-float+ "getValue"
                            (lisp-object-arg-types 1) :double))
825
        (t
826 827
         (emit-checkcast +lisp-double-float+)
         (emit-getfield +lisp-double-float+ "value" :double))))
828

829 830 831 832 833 834 835 836
(defknown fix-boxing (t t) t)
(defun fix-boxing (required-representation derived-type)
  "Generate code to convert a boxed LispObject on the stack to the specified
representation, based on the derived type of the LispObject."
  (cond ((null required-representation)) ; Nothing to do.
        ((eq required-representation :int)
         (cond ((and (fixnum-type-p derived-type)
                     (< *safety* 3))
837 838
                (emit-checkcast +lisp-fixnum+)
                (emit-getfield +lisp-fixnum+ "value" :int))
839
               (t
840
                (emit-invokevirtual +lisp-object+ "intValue" nil :int))))
841 842 843 844 845
        ((eq required-representation :char)
         (emit-unbox-character))
        ((eq required-representation :boolean)
         (emit-unbox-boolean))
        ((eq required-representation :long)
846
         (emit-invokevirtual +lisp-object+ "longValue" nil :long))
847
        ((eq required-representation :float)
848
         (emit-invokevirtual +lisp-object+ "floatValue" nil :float))
849
        ((eq required-representation :double)
850
         (emit-invokevirtual +lisp-object+ "doubleValue" nil :double))
851
        (t (assert nil))))
852 853 854 855 856

(defknown emit-move-from-stack (t &optional t) t)
(defun emit-move-from-stack (target &optional representation)
  (declare (optimize speed))
  (cond ((null target)
857
         (ecase representation
858 859
           ((:long :double)
            (emit 'pop2))
860
           ((NIL :int :boolean :char :float)
861
            (emit 'pop))))
862 863 864
        ((eq target 'stack)) ; Nothing to do.
        ((fixnump target)
         ;; A register.
865 866 867 868 869 870 871 872
         (emit (ecase representation
                 ((:int :boolean :char)
                          'istore)
                 (:long   'lstore)
                 (:float  'fstore)
                 (:double 'dstore)
                 ((nil)   'astore))
               target))
873
        (t
874
         (sys::%format t "emit-move-from-stack general case~%")
875 876
         (aver nil))))

877 878 879 880 881 882 883 884 885 886 887 888 889
(defknown emit-push-register (t &optional t) t)
(defun emit-push-register (source &optional representation)
  (declare (optimize speed))
  (assert (fixnump source))
  (emit (ecase representation
               ((:int :boolean :char)
                        'iload)
               (:long   'lload)
               (:float  'fload)
               (:double 'dload)
               ((nil)   'aload))
        source))

890 891 892
;; Expects value on stack.
(defknown emit-invoke-method (t t t) t)
(defun emit-invoke-method (method-name target representation)
893
  (emit-invokevirtual +lisp-object+ method-name nil +lisp-object+)
894 895 896 897 898 899 900 901 902 903 904
  (fix-boxing representation nil)
  (emit-move-from-stack target representation))

;; "In addition to situations for which the standard specifies that conditions
;; of type WARNING must or might be signaled, warnings might be signaled in
;; situations where the compiler can determine that the consequences are
;; undefined or that a run-time error will be signaled. Examples of this
;; situation are as follows: violating type declarations, altering or assigning
;; the value of a constant defined with DEFCONSTANT, calling built-in Lisp
;; functions with a wrong number of arguments or malformed keyword argument
;; lists, and using unrecognized declaration specifiers." (3.2.5)
905
(defun check-number-of-args (form n &optional minimum)
906 907 908
  (declare (type fixnum n))
  (let* ((op (car form))
         (args (cdr form))
909
         (ok (if minimum
910 911
                 (>= (length args) n)
                 (= (length args) n))))
912 913 914 915 916
    (declare (type boolean ok))
    (unless ok
      (funcall (if (eq (symbol-package op) +cl-package+)
                   #'compiler-warn ; See above!
                   #'compiler-style-warn)
917 918
               "Wrong number of arguments for ~A (expected~:[~; at least~] ~D, but received ~D)."
               op minimum n (length args)))
919 920
    ok))

921 922 923 924
(defknown check-arg-count (t fixnum) t)
(defun check-arg-count (form n)
  (check-number-of-args form n))

925 926
(declaim (ftype (function (t fixnum) t) check-min-args))
(defun check-min-args (form n)
927
  (check-number-of-args form n t))
928 929


930

931 932 933 934
(defun emit-constructor-lambda-name (lambda-name)
  (cond ((and lambda-name (symbolp lambda-name) (symbol-package (truly-the symbol lambda-name)))
         (emit 'ldc (pool-string (symbol-name (truly-the symbol lambda-name))))
         (emit 'ldc (pool-string (package-name (symbol-package (truly-the symbol lambda-name)))))
935 936 937
         (emit-invokestatic +lisp+ "internInPackage"
                            (list +java-string+ +java-string+)
                            +lisp-symbol+))
938 939 940 941 942 943
        (t
         ;; No name.
         (emit-push-nil))))

(defun emit-constructor-lambda-list (lambda-list)
  (if lambda-list
944
      (serialize-object lambda-list)
945 946
      (emit-push-nil)))

947 948 949
(defun emit-read-from-string (object)
  (emit-constructor-lambda-list object))

950
(defun make-constructor (class lambda-name args)
951
  (let* ((*compiler-debug* nil)
952 953
         (method (make-jvm-method :constructor :void nil
				  :flags '(:public)))
954
         ;; We don't normally need to see debugging output for constructors.
955
         (super (class-file-superclass class))
956 957
         opt-params-register
         key-params-register
958
         req-count
959 960
         rest-p
         keys-p
961 962
         more-keys-p
         alp-register)
963
    (with-code-to-method (class method)
964
      (allocate-register nil)
965 966 967 968 969 970 971
      (unless (eq super +lisp-compiled-primitive+)
        (multiple-value-bind
             (req opt key key-p rest
                  allow-other-keys-p)
            (parse-lambda-list args)
          (setf rest-p rest
                more-keys-p allow-other-keys-p
972 973
                keys-p key-p
                req-count (length req))
974
          (macrolet
975
              ((parameters-to-array ((param params register class) &body body)
976 977 978
                 (let ((count-sym (gensym)))
                   `(progn
                      (emit-push-constant-int (length ,params))
979
                      (emit-anewarray ,class)
980
                      (astore (setf ,register *registers-allocated*))
981
                      (allocate-register nil)
982 983 984 985 986 987 988
                      (do* ((,count-sym 0 (1+ ,count-sym))
                            (,params ,params (cdr ,params))
                            (,param (car ,params) (car ,params)))
                           ((endp ,params))
                        (declare (ignorable ,param))
                        (aload ,register)
                        (emit-push-constant-int ,count-sym)
989
                        (emit-new ,class)
990 991 992
                        (emit 'dup)
                        ,@body
                        (emit 'aastore))))))
993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006
             (parameters-to-array (param opt opt-params-register
                                         +alp-optional-parameter+)
               (if (null (third param)) ;; supplied-p or not?
                   (emit 'iconst_0)
                   (emit 'iconst_1))
               (emit-read-from-string (second param)) ;; initform
               (emit-invokespecial-init +alp-optional-parameter+
                                        (list :boolean +lisp-object+)))

            (parameters-to-array (param key key-params-register
                                        +alp-keyword-parameter+)
               (if (null (third param)) ;; supplied-p or not?
                   (emit 'iconst_0)
                   (emit 'iconst_1))
1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021
               (emit-read-from-string (second param)) ;; initform
               (let ((keyword (fourth param)))
                 (if (keywordp keyword)
                     (progn
                       (emit 'ldc (pool-string (symbol-name keyword)))
                       (emit-invokestatic +lisp+ "internKeyword"
                                          (list +java-string+) +lisp-symbol+))
                     ;; symbol is not really a keyword; yes, that's allowed!
                     (progn
                       (emit 'ldc (pool-string (symbol-name keyword)))
                       (emit 'ldc (pool-string
                                   (package-name (symbol-package keyword))))
                       (emit-invokestatic +lisp+ "internInPackage"
                                          (list +java-string+ +java-string+)
                                          +lisp-symbol+))))
1022 1023 1024
               (emit-invokespecial-init +alp-keyword-parameter+
                                        (list :boolean +lisp-object+
                                              +lisp-symbol+))))))
1025 1026 1027 1028 1029
      (aload 0) ;; this
      (cond ((eq super +lisp-compiled-primitive+)
             (emit-constructor-lambda-name lambda-name)
             (emit-constructor-lambda-list args)
             (emit-invokespecial-init super (lisp-object-arg-types 2)))
1030 1031 1032 1033 1034 1035 1036 1037
            ((equal super +lisp-compiled-closure+)
             ;;### only needs EQ when SUPER is guaranteed to be CLASS-NAME
             (emit-new +argument-list-processor+)
             (emit 'dup)
             (emit 'dup)
             (astore (setf alp-register (allocate-register nil)))
             (emit 'aconst_null)
             (emit-push-int req-count)
1038 1039 1040
             (aload opt-params-register)
             (aload key-params-register)
             (if keys-p
1041 1042
                 (emit 'iconst_1)
                 (emit 'iconst_0))
1043
             (if more-keys-p
1044 1045 1046
                 (emit 'iconst_1)
                 (emit 'iconst_0))
             (if rest-p
1047
                 (emit-push-t)
1048 1049 1050 1051 1052 1053 1054 1055 1056 1057
                 (emit 'aconst_null))
             (emit-invokespecial-init +argument-list-processor+
                                      (list
                                       +lisp-operator+
                                       :int
                                       (class-array +alp-optional-parameter+)
                                       (class-array +alp-keyword-parameter+)
                                       :boolean
                                       :boolean
                                       +lisp-symbol+))
1058
             (emit-invokespecial-init super
1059 1060 1061 1062 1063 1064
                                      (list +argument-list-processor+))
             (aload alp-register)
             (aload 0)
             (emit-invokevirtual +argument-list-processor+
                                 "setFunction"
                                 (list +lisp-operator+) nil))
1065 1066 1067 1068 1069
            (t
             (sys::%format t "unhandled superclass ~A for ~A~%"
                           super
                           (abcl-class-file-class-name class))
             (aver nil))))
1070 1071
    method))

1072 1073
(defun make-static-initializer (class)
  (let ((*compiler-debug* nil)
1074
        (method (make-jvm-method :static-initializer
1075
                                 :void nil :flags '(:public :static))))
1076 1077 1078
    ;; We don't normally need to see debugging output for <clinit>.
    (with-code-to-method (class method)
      method)))
1079 1080 1081 1082

(defvar *source-line-number* nil)


1083 1084
(defun finish-class (class stream)
  "Finalizes the `class' and writes the result to `stream'.
1085

1086 1087
The compiler calls this function to indicate it doesn't want to
extend the class any further."
1088 1089
  (with-code-to-method (class (abcl-class-file-constructor class))
    (emit 'return))
1090
  (with-code-to-method (class (abcl-class-file-static-initializer class))
1091 1092 1093
    (if (= 0 (length *code*))
        (class-remove-method class (abcl-class-file-static-initializer class))
        (emit 'return)))
1094 1095 1096 1097
  (when *compiler-debug*
    (print "; Writing class file ")
    (print (abcl-class-file-class-name class))
    (terpri))
1098 1099
  (finalize-class-file class)
  (write-class-file class stream))
1100

1101 1102

(defknown declare-field (t t t) t)
1103
(defun declare-field (name descriptor)
1104
  (let ((field (make-field name descriptor :flags '(:final :static))))
1105
    (class-add-field *class-file* field)))
1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124

(defknown sanitize (symbol) string)
(defun sanitize (symbol)
  (declare (type symbol symbol))
  (declare (optimize speed))
  (let* ((input (symbol-name symbol))
         (output (make-array (length input) :fill-pointer 0 :element-type 'character)))
    (dotimes (i (length input))
      (declare (type fixnum i))
      (let ((c (char-upcase (char input i))))
        (cond ((<= #.(char-code #\A) (char-code c) #.(char-code #\Z))
               (vector-push c output))
              ((<= #.(char-code #\0) (char-code c) #.(char-code #\9))
               (vector-push c output))
              ((eql c #\-)
               (vector-push #\_ output)))))
    (when (plusp (length output))
      output)))

1125 1126
(defvar *declare-inline* nil)

1127
(defmacro declare-with-hashtable (declared-item hashtable hashtable-var
1128
                                  item-var &body body)
1129
  `(let* ((,hashtable-var ,hashtable)
1130
          (,item-var (gethash1 ,declared-item ,hashtable-var)))
1131 1132 1133 1134 1135
     (declare (type hash-table ,hashtable-var))
     (unless ,item-var
       ,@body)
     ,item-var))

1136 1137 1138 1139 1140 1141 1142 1143 1144 1145
;; The protocol of the serialize-* functions is to serialize
;; the type to which they apply and emit code which leaves the
;; restored object on the stack.

;; The functions may generate only Java code, or decide to defer
;; some of the process of restoring the object to the reader. The
;; latter is generally applicable to more complex structures.

;; This way, the serialize-* functions can be used to depend on
;; each other to serialize nested constructs. They are also the
1146 1147
;; building blocks of the EMIT-LOAD-EXTERNALIZED-OBJECT function,
;; which is called from the compiler.
1148 1149 1150 1151

(defun serialize-integer (n)
  "Generates code to restore a serialized integer."
  (cond((<= 0 n 255)
1152
        (emit-getstatic +lisp-fixnum+ "constants" +lisp-fixnum-array+)
1153 1154 1155 1156
        (emit-push-constant-int n)
        (emit 'aaload))
       ((<= most-negative-fixnum n most-positive-fixnum)
        (emit-push-constant-int n)
1157 1158
        (emit-invokestatic +lisp-fixnum+ "getInstance"
                           '(:int) +lisp-fixnum+))
1159 1160
       ((<= most-negative-java-long n most-positive-java-long)
        (emit-push-constant-long n)
1161 1162
        (emit-invokestatic +lisp-bignum+ "getInstance"
                           '(:long) +lisp-integer+))
1163 1164 1165 1166 1167
       (t
        (let* ((*print-base* 10)
               (s (with-output-to-string (stream) (dump-form n stream))))
          (emit 'ldc (pool-string s))
          (emit-push-constant-int 10)
1168 1169
          (emit-invokestatic +lisp-bignum+ "getInstance"
                             (list +java-string+ :int) +lisp-integer+)))))
1170 1171 1172 1173

(defun serialize-character (c)
  "Generates code to restore a serialized character."
  (emit-push-constant-int (char-code c))
1174
  (emit-invokestatic +lisp-character+ "getInstance" '(:char)
1175 1176 1177 1178
                     +lisp-character+))

(defun serialize-float (s)
  "Generates code to restore a serialized single-float."
1179
  (emit-new +lisp-single-float+)
1180 1181
  (emit 'dup)
  (emit 'ldc (pool-float s))
1182
  (emit-invokespecial-init +lisp-single-float+ '(:float)))
1183 1184 1185

(defun serialize-double (d)
  "Generates code to restore a serialized double-float."
1186
  (emit-new +lisp-double-float+)
1187 1188
  (emit 'dup)
  (emit 'ldc2_w (pool-double d))
1189
  (emit-invokespecial-init +lisp-double-float+ '(:double)))
1190 1191 1192

(defun serialize-string (string)
  "Generate code to restore a serialized string."
1193 1194 1195 1196 1197 1198 1199 1200
  (cond
    ((< (length string) #xFFFF)
     (emit-new +lisp-simple-string+)
     (emit 'dup)
     (emit 'ldc (pool-string string))
     (emit-invokespecial-init +lisp-simple-string+ (list +java-string+)))
    (t
     (serialize-object string))))
1201 1202 1203

(defun serialize-package (pkg)
  "Generate code to restore a serialized package."
1204
  (emit 'ldc (pool-string (concatenate 'string "#.(CL:FIND-PACKAGE \""
1205
                                       (package-name pkg) "\")")))
1206
  (emit-invokestatic +lisp+ "readObjectFromString"
1207 1208
                     (list +java-string+) +lisp-object+))

1209 1210 1211 1212 1213 1214 1215 1216
(defun compiland-external-constant-resource-name (compiland)
  (let ((resource-number (compiland-next-resource compiland))
        (pathname (abcl-class-file-pathname (compiland-class-file compiland))))
    (incf (compiland-next-resource compiland))
    (make-pathname :name (format nil "~A_~D"
                                 (pathname-name pathname) resource-number)
                   :type "clc"
                   :defaults pathname)))
1217

1218 1219 1220 1221 1222
(defun serialize-object (object)
  "Generate code to restore a serialized object which is not of any
of the other types."
  (let ((s (with-output-to-string (stream)
             (dump-form object stream))))
1223 1224 1225 1226 1227 1228
    (cond
      ((< (length s) #xFFFF)  ;; maximum string size in class file
       (emit 'ldc (pool-string s))
       (emit-invokestatic +lisp+ "readObjectFromString"
                          (list +java-string+) +lisp-object+))
      (t
1229 1230
        ;; get a 'class literal' for this class
       (emit 'ldc_w (pool-class *this-class*))
1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241
       (let ((pathname
              (compiland-external-constant-resource-name *current-compiland*)))
         (with-open-file (f pathname
                            :direction :output
                            :if-exists :supersede
                            :if-does-not-exist :create)
           (write-string s f))
         (emit 'ldc (pool-string
                     (namestring (make-pathname :name (pathname-name pathname)
                                                :type (pathname-type pathname)
                                                :version nil)))))
1242 1243 1244 1245 1246 1247
       (emit-invokevirtual +java-class+ "getResourceAsStream"
                           (list +java-string+)
                           +java-io-input-stream+)
       (emit-invokestatic +lisp+ "readObjectFromStream"
                          (list +java-io-input-stream+)
                          +lisp-object+)))))
1248 1249 1250

(defun serialize-symbol (symbol)
  "Generate code to restore a serialized symbol."
1251 1252 1253 1254 1255
  (multiple-value-bind
        (name class)
      (lookup-known-symbol symbol)
    (cond
      (name
1256
       (emit-getstatic class name +lisp-symbol+))
1257
      ((null (symbol-package symbol))
1258
       (emit-push-constant-int (dump-uninterned-symbol-index symbol))
1259
       (emit-invokestatic +lisp-load+ "getUninternedSymbol" '(:int)
1260
                          +lisp-object+)
1261
       (emit-checkcast +lisp-symbol+))
1262 1263
      ((keywordp symbol)
       (emit 'ldc (pool-string (symbol-name symbol)))
1264
       (emit-invokestatic +lisp+ "internKeyword"
1265 1266 1267 1268
                          (list +java-string+) +lisp-symbol+))
      (t
       (emit 'ldc (pool-string (symbol-name symbol)))
       (emit 'ldc (pool-string (package-name (symbol-package symbol))))
1269
       (emit-invokestatic +lisp+ "internInPackage"
1270 1271
                          (list +java-string+ +java-string+)
                          +lisp-symbol+)))))
1272 1273 1274 1275 1276 1277

(defvar serialization-table
  `((integer "INT" ,#'eql ,#'serialize-integer ,+lisp-integer+)
    (character "CHR" ,#'eql ,#'serialize-character ,+lisp-character+)
    (single-float "FLT" ,#'eql ,#'serialize-float ,+lisp-single-float+)
    (double-float "DBL" ,#'eql ,#'serialize-double ,+lisp-double-float+)
1278 1279
    (string "STR" ,#'equal ,#'serialize-string
            ,+lisp-abstract-string+) ;; because of (not compile-file)
1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290
    (package "PKG" ,#'eq ,#'serialize-package ,+lisp-object+)
    (symbol "SYM" ,#'eq ,#'serialize-symbol ,+lisp-symbol+)
    (T "OBJ" ,#'eq ,#'serialize-object ,+lisp-object+))
  "A list of 5-element lists. The elements of the sublists mean:

1. The type of the value to be serialized
2. The string to be used as a field prefix
3. The function to be used to determine equality (coalescing or not)
4. The function to dispatch serialization to
5. The type of the field to save the serialized result to")

1291
(defknown emit-load-externalized-object (t &optional t) string)
1292
(defun emit-load-externalized-object (object &optional cast)
1293 1294 1295 1296 1297 1298
  "Externalizes `object' for use in a FASL.

Returns the name of the field (in `*this-class*') from which
the value of the object can be loaded. Objects may be coalesced based
on the equality indicator in the `serialization-table'.

1299 1300
Code to restore the serialized object is inserted into the current method or
the constructor if `*declare-inline*' is non-nil.
1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313
"
  ;; TODO: rewrite to become EMIT-LOAD-EXTERNALIZED-OBJECT which
  ;; - instead of returning the name of the field - returns the type
  ;; of the field it just loaded (to allow casting and what not).
  ;; The function should still do what it does today: de-serialize the
  ;; object and storing its value.

  (destructuring-bind
        (type prefix similarity-fn dispatch-fn field-type)
      (assoc-if #'(lambda (x)
                    (typep object x))
                serialization-table)
    (declare (ignore type)) ;; the type has been used in the selection process
1314 1315
    (when (not *file-compilation*) ;; in-memory compilation wants object EQ-ness
      (setf similarity-fn #'eq))
1316 1317
    (let ((existing (assoc object *externalized-objects* :test similarity-fn)))
      (when existing
1318
        (emit-getstatic *this-class* (cdr existing) field-type)
1319
        (when cast
1320
          (emit-checkcast cast))
1321
        (return-from emit-load-externalized-object field-type)))
1322 1323 1324

    ;; We need to set up the serialized value
    (let ((field-name (symbol-name (gensym prefix))))
1325
      (declare-field field-name field-type)
1326 1327
      (push (cons object field-name) *externalized-objects*)

1328 1329
      (cond
        ((not *file-compilation*)
1330
         (with-code-to-method
1331
             (*class-file* (abcl-class-file-static-initializer *class-file*))
1332 1333
           (remember field-name object)
           (emit 'ldc (pool-string field-name))
1334
           (emit-invokestatic +lisp+ "recall"
1335
                              (list +java-string+) +lisp-object+)
1336 1337
           (when (not (eq field-type +lisp-object+))
             (emit-checkcast field-type))
1338
           (emit-putstatic *this-class* field-name field-type)))
1339 1340
        (*declare-inline*
         (funcall dispatch-fn object)
1341
         (emit-putstatic *this-class* field-name field-type))
1342
        (t
1343
         (with-code-to-method
1344
             (*class-file* (abcl-class-file-static-initializer *class-file*))
1345
           (funcall dispatch-fn object)
1346
           (emit-putstatic *this-class* field-name field-type))))
1347

1348
      (emit-getstatic *this-class* field-name field-type)
1349
      (when cast
1350
        (emit-checkcast cast))
1351
      field-type)))
1352

1353 1354
(defknown declare-function (symbol &optional setf) string)
(defun declare-function (symbol &optional setf)
1355
  (declare (type symbol symbol))
1356 1357
  (declare-with-hashtable
   symbol *declared-functions* ht f
1358
   (setf f (symbol-name (if setf (gensym "SETF") (gensym "FUN"))))
1359 1360 1361
   (let ((s (sanitize symbol)))
     (when s
       (setf f (concatenate 'string f "_" s))))
1362
   (declare-field f +lisp-object+)
1363 1364
   (multiple-value-bind
         (name class)
1365 1366
       (lookup-known-symbol symbol)
     ;; This is a work-around for the fact that
1367
     ;; EMIT-LOAD-EXTERNALIZED-OBJECT can't be used due to the fact that