Changeset 11455


Ignore:
Timestamp:
12/20/08 13:43:29 (13 years ago)
Author:
vvoutilainen
Message:

Split up the compiler in three separate parts in
preparation to further cleanups.

Location:
trunk/j/src/org/armedbear/lisp
Files:
2 added
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/compile-system.lisp

    r11391 r11455  
    8989    (load (compile-file-if-needed "compile-file.lisp"))
    9090    (load (compile-file-if-needed "precompiler.lisp"))
     91    (load (compile-file-if-needed "compiler-pass1.lisp"))
     92    (load (compile-file-if-needed "compiler-pass2.lisp"))
    9193    (load (compile-file-if-needed "jvm.lisp"))
    9294    (load (compile-file-if-needed "source-transform.lisp"))
  • trunk/j/src/org/armedbear/lisp/jvm.lisp

    r11453 r11455  
    3232(in-package "EXTENSIONS")
    3333
    34 (export 'defsubst)
    35 
    3634(in-package "JVM")
    3735
     
    4947  (require "DUMP-FORM")
    5048  (require "OPCODES")
    51   (require "JAVA"))
     49  (require "JAVA")
     50  (require "COMPILER-PASS1")
     51  (require "COMPILER-PASS2"))
    5252
    5353(defvar *closure-variables* nil)
     
    7575
    7676
    77 (eval-when (:compile-toplevel :load-toplevel :execute)
    78   (defun generate-inline-expansion (block-name lambda-list body)
    79     (cond ((intersection lambda-list '(&optional &rest &key &allow-other-keys &aux) :test 'eq)
    80            nil)
    81           (t
    82            (setf body (copy-tree body))
    83            (list 'LAMBDA lambda-list (precompile-form (list* 'BLOCK block-name body) t)))))
    84   ) ; EVAL-WHEN
    85 
    86 ;; Just an experiment...
    87 (defmacro defsubst (name lambda-list &rest body)
    88   (let* ((block-name (fdefinition-block-name name))
    89          (expansion (generate-inline-expansion block-name lambda-list body)))
    90 ;;     (format t "expansion = ~S~%" expansion)
    91     `(progn
    92        (%defun ',name (lambda ,lambda-list (block ,block-name ,@body)))
    93        (precompile ',name)
    94        (eval-when (:compile-toplevel :load-toplevel :execute)
    95          (setf (inline-expansion ',name) ',expansion))
    96        ',name)))
    97 
    98 #+nil
    99 (defmacro defsubst (&rest args)
    100   `(defun ,@args))
    10177
    10278(defvar *compiler-debug* nil)
     
    408384  (compiland *current-compiland*))
    409385
    410 ;;; Pass 1.
    411 
    412386(defun process-ignore/ignorable (declaration names variables)
    413387  (when (memq declaration '(IGNORE IGNORABLE))
     
    426400                 (setf (variable-ignorable-p variable) t))))))))
    427401
    428 ;; Returns a list of declared free specials, if any are found.
    429 (declaim (ftype (function (list list) list) process-declarations-for-vars))
    430 (defun process-declarations-for-vars (body variables)
    431   (let ((free-specials '()))
    432     (dolist (subform body)
    433       (unless (and (consp subform) (eq (%car subform) 'DECLARE))
    434         (return))
    435       (let ((decls (%cdr subform)))
    436         (dolist (decl decls)
    437           (case (car decl)
    438             ((DYNAMIC-EXTENT FTYPE INLINE NOTINLINE OPTIMIZE)
    439              ;; Nothing to do here.
    440              )
    441             ((IGNORE IGNORABLE)
    442              (process-ignore/ignorable (%car decl) (%cdr decl) variables))
    443             (SPECIAL
    444              (dolist (name (%cdr decl))
    445                (let ((variable (find-variable name variables)))
    446                  (cond ((and variable
    447                              ;; see comment below (and DO-ALL-SYMBOLS.11)
    448                              (eq (variable-compiland variable) *current-compiland*))
    449                         (setf (variable-special-p variable) t))
    450                        (t
    451                         (dformat t "adding free special ~S~%" name)
    452                         (push (make-variable :name name :special-p t) free-specials))))))
    453             (TYPE
    454              (dolist (name (cddr decl))
    455                (let ((variable (find-variable name variables)))
    456                  (when (and variable
    457                             ;; Don't apply a declaration in a local function to
    458                             ;; a variable defined in its parent. For an example,
    459                             ;; see CREATE-GREEDY-NO-ZERO-MATCHER in cl-ppcre.
    460                             ;; FIXME suboptimal, since we ignore the declaration
    461                             (eq (variable-compiland variable) *current-compiland*))
    462                    (setf (variable-declared-type variable)
    463                          (make-compiler-type (cadr decl)))))))
    464             (t
    465              (dolist (name (cdr decl))
    466                (let ((variable (find-variable name variables)))
    467                  (when variable
    468                    (setf (variable-declared-type variable)
    469                          (make-compiler-type (%car decl)))))))))))
    470     free-specials))
    471 
    472 (defun check-name (name)
    473   ;; FIXME Currently this error is signalled by the precompiler.
    474   (unless (symbolp name)
    475     (compiler-error "The variable ~S is not a symbol." name))
    476   (when (constantp name)
    477     (compiler-error "The name of the variable ~S is already in use to name a constant." name))
    478   name)
    479 
    480 (declaim (ftype (function (t) t) p1-body))
    481 (defun p1-body (body)
    482   (declare (optimize speed))
    483   (let ((tail body))
    484     (loop
    485       (when (endp tail)
    486         (return))
    487       (setf (car tail) (p1 (%car tail)))
    488       (setf tail (%cdr tail))))
    489   body)
    490 
    491 (defknown p1-default (t) t)
    492 (declaim (inline p1-default))
    493 (defun p1-default (form)
    494   (setf (cdr form) (p1-body (cdr form)))
    495   form)
    496 
    497 (defknown p1-if (t) t)
    498 (defun p1-if (form)
    499   (let ((test (cadr form)))
    500     (cond ((unsafe-p test)
    501            (cond ((and (consp test)
    502                        (memq (%car test) '(GO RETURN-FROM THROW)))
    503                   (p1 test))
    504                  (t
    505                   (let* ((var (gensym))
    506                          (new-form
    507                           `(let ((,var ,test))
    508                              (if ,var ,(third form) ,(fourth form)))))
    509                     (p1 new-form)))))
    510           (t
    511            (p1-default form)))))
    512 
    513 (defknown p1-let-vars (t) t)
    514 (defun p1-let-vars (varlist)
    515   (let ((vars ()))
    516     (dolist (varspec varlist)
    517       (cond ((consp varspec)
    518               ;; FIXME Currently this error is signalled by the precompiler.
    519              (unless (= (length varspec) 2)
    520                (compiler-error "The LET binding specification ~S is invalid."
    521                                varspec))
    522              (let ((name (check-name (%car varspec)))
    523                    (initform (p1 (%cadr varspec))))
    524                (push (make-variable :name name :initform initform) vars)))
    525             (t
    526              (push (make-variable :name (check-name varspec)) vars))))
    527     (setf vars (nreverse vars))
    528     (dolist (variable vars)
    529       (push variable *visible-variables*)
    530       (push variable *all-variables*))
    531     vars))
    532 
    533 (defknown p1-let*-vars (t) t)
    534 (defun p1-let*-vars (varlist)
    535   (let ((vars ()))
    536     (dolist (varspec varlist)
    537       (cond ((consp varspec)
    538               ;; FIXME Currently this error is signalled by the precompiler.
    539              (unless (= (length varspec) 2)
    540                (compiler-error "The LET* binding specification ~S is invalid."
    541                                varspec))
    542              (let* ((name (%car varspec))
    543                     (initform (p1 (%cadr varspec)))
    544                     (var (make-variable :name (check-name name) :initform initform)))
    545                (push var vars)
    546                (push var *visible-variables*)
    547                (push var *all-variables*)))
    548             (t
    549              (let ((var (make-variable :name (check-name varspec))))
    550                (push var vars)
    551                (push var *visible-variables*)
    552                (push var *all-variables*)))))
    553     (nreverse vars)))
    554 
    555 (defun p1-let/let* (form)
    556   (declare (type cons form))
    557   (let* ((*visible-variables* *visible-variables*)
    558          (block (make-block-node '(LET)))
    559          (*blocks* (cons block *blocks*))
    560          (op (%car form))
    561          (varlist (cadr form))
    562          (body (cddr form)))
    563     (aver (or (eq op 'LET) (eq op 'LET*)))
    564     (when (eq op 'LET)
    565       ;; Convert to LET* if possible.
    566       (if (null (cdr varlist))
    567           (setf op 'LET*)
    568           (dolist (varspec varlist (setf op 'LET*))
    569             (or (atom varspec)
    570                 (constantp (cadr varspec))
    571                 (eq (car varspec) (cadr varspec))
    572                 (return)))))
    573     (let ((vars (if (eq op 'LET)
    574                     (p1-let-vars varlist)
    575                     (p1-let*-vars varlist))))
    576       ;; Check for globally declared specials.
    577       (dolist (variable vars)
    578         (when (special-variable-p (variable-name variable))
    579           (setf (variable-special-p variable) t)))
    580       ;; For processing declarations, we want to walk the variable list from
    581       ;; last to first, since declarations apply to the last-defined variable
    582       ;; with the specified name.
    583       (setf (block-free-specials block) (process-declarations-for-vars body (reverse vars)))
    584       (setf (block-vars block) vars)
    585       ;; Make free specials visible.
    586       (dolist (variable (block-free-specials block))
    587         (push variable *visible-variables*)))
    588     (setf body (p1-body body))
    589     (setf (block-form block) (list* op varlist body))
    590     block))
    591 
    592 (defun p1-locally (form)
    593   (let ((*visible-variables* *visible-variables*)
    594         (specials (process-special-declarations (cdr form))))
    595     (dolist (name specials)
    596 ;;       (format t "p1-locally ~S is special~%" name)
    597       (push (make-variable :name name :special-p t) *visible-variables*))
    598     (setf (cdr form) (p1-body (cdr form)))
    599     form))
    600 
    601 (defknown p1-m-v-b (t) t)
    602 (defun p1-m-v-b (form)
    603   (when (= (length (cadr form)) 1)
    604     (let ((new-form `(let* ((,(caadr form) ,(caddr form))) ,@(cdddr form))))
    605       (return-from p1-m-v-b (p1-let/let* new-form))))
    606   (let* ((*visible-variables* *visible-variables*)
    607          (block (make-block-node '(MULTIPLE-VALUE-BIND)))
    608          (*blocks* (cons block *blocks*))
    609          (varlist (cadr form))
    610          (values-form (caddr form))
    611          (body (cdddr form)))
    612     ;; Process the values-form first. ("The scopes of the name binding and
    613     ;; declarations do not include the values-form.")
    614     (setf values-form (p1 values-form))
    615     (let ((vars ()))
    616       (dolist (symbol varlist)
    617         (let ((var (make-variable :name symbol)))
    618           (push var vars)
    619           (push var *visible-variables*)
    620           (push var *all-variables*)))
    621       ;; Check for globally declared specials.
    622       (dolist (variable vars)
    623         (when (special-variable-p (variable-name variable))
    624           (setf (variable-special-p variable) t)))
    625       (setf (block-free-specials block) (process-declarations-for-vars body vars))
    626       (setf (block-vars block) (nreverse vars)))
    627     (setf body (p1-body body))
    628     (setf (block-form block) (list* 'MULTIPLE-VALUE-BIND varlist values-form body))
    629     block))
    630 
    631 (defun p1-block (form)
    632   (let* ((block (make-block-node (cadr form)))
    633          (*blocks* (cons block *blocks*)))
    634     (setf (cddr form) (p1-body (cddr form)))
    635     (setf (block-form block) form)
    636     block))
    637 
    638 (defun p1-catch (form)
    639   (let* ((tag (p1 (cadr form)))
    640          (body (cddr form))
    641          (result '()))
    642     (dolist (subform body)
    643       (let ((op (and (consp subform) (%car subform))))
    644         (push (p1 subform) result)
    645         (when (memq op '(GO RETURN-FROM THROW))
    646           (return))))
    647     (setf result (nreverse result))
    648     (when (and (null (cdr result))
    649                (consp (car result))
    650                (eq (caar result) 'GO))
    651       (return-from p1-catch (car result)))
    652     (push tag result)
    653     (push 'CATCH result)
    654     (let ((block (make-block-node '(CATCH))))
    655       (setf (block-form block) result)
    656       block)))
    657 
    658 (defun p1-unwind-protect (form)
    659   (if (= (length form) 2)
    660       (p1 (second form)) ; No cleanup forms: (unwind-protect (...)) => (...)
    661       (let* ((block (make-block-node '(UNWIND-PROTECT)))
    662              (*blocks* (cons block *blocks*)))
    663         (setf (block-form block) (p1-default form))
    664         block)))
    665 
    666 (defknown p1-return-from (t) t)
    667 (defun p1-return-from (form)
    668   (let* ((name (second form))
    669          (block (find-block name)))
    670     (when (null block)
    671       (compiler-error "RETURN-FROM ~S: no block named ~S is currently visible."
    672                       name name))
    673     (dformat t "p1-return-from block = ~S~%" (block-name block))
    674     (setf (block-return-p block) t)
    675     (cond ((eq (block-compiland block) *current-compiland*)
    676            ;; Local case. If the RETURN is nested inside an UNWIND-PROTECT
    677            ;; which is inside the block we're returning from, we'll do a non-
    678            ;; local return anyway so that UNWIND-PROTECT can catch it and run
    679            ;; its cleanup forms.
    680            (dformat t "*blocks* = ~S~%" (mapcar #'block-name *blocks*))
    681            (let ((protected
    682                   (dolist (enclosing-block *blocks*)
    683                     (when (eq enclosing-block block)
    684                       (return nil))
    685                     (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
    686                       (return t)))))
    687              (dformat t "p1-return-from protected = ~S~%" protected)
    688              (when protected
    689                (setf (block-non-local-return-p block) t))))
    690           (t
    691            (setf (block-non-local-return-p block) t)))
    692     (when (block-non-local-return-p block)
    693       (dformat t "non-local return from block ~S~%" (block-name block))))
    694   (list* 'RETURN-FROM (cadr form) (mapcar #'p1 (cddr form))))
    695 
    696 (defun p1-tagbody (form)
    697   (let* ((block (make-block-node '(TAGBODY)))
    698          (*blocks* (cons block *blocks*))
    699          (*visible-tags* *visible-tags*)
    700          (body (cdr form)))
    701     ;; Make all the tags visible before processing the body forms.
    702     (dolist (subform body)
    703       (when (or (symbolp subform) (integerp subform))
    704         (let* ((tag (make-tag :name subform :label (gensym) :block block)))
    705           (push tag *visible-tags*))))
    706     (let ((new-body '())
    707           (live t))
    708       (dolist (subform body)
    709         (cond ((or (symbolp subform) (integerp subform))
    710                (push subform new-body)
    711                (setf live t))
    712               ((not live)
    713                ;; Nothing to do.
    714                )
    715               (t
    716                (when (and (consp subform)
    717                           (memq (%car subform) '(GO RETURN-FROM THROW)))
    718                  ;; Subsequent subforms are unreachable until we see another
    719                  ;; tag.
    720                  (setf live nil))
    721                (push (p1 subform) new-body))))
    722       (setf (block-form block) (list* 'TAGBODY (nreverse new-body))))
    723     block))
    724 
    725 (defknown p1-go (t) t)
    726 (defun p1-go (form)
    727   (let* ((name (cadr form))
    728          (tag (find-tag name)))
    729     (unless tag
    730       (error "p1-go: tag not found: ~S" name))
    731     (let ((tag-block (tag-block tag)))
    732       (cond ((eq (tag-compiland tag) *current-compiland*)
    733              ;; Does the GO leave an enclosing UNWIND-PROTECT?
    734              (let ((protected
    735                     (dolist (enclosing-block *blocks*)
    736                       (when (eq enclosing-block tag-block)
    737                         (return nil))
    738                       (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
    739                         (return t)))))
    740                (when protected
    741                  (setf (block-non-local-go-p tag-block) t))))
    742             (t
    743              (setf (block-non-local-go-p tag-block) t)))))
    744   form)
    745 
    746 (defun validate-name-and-lambda-list (name lambda-list context)
    747   (unless (or (symbolp name) (setf-function-name-p name))
    748     (compiler-error "~S is not a valid function name." name))
    749   (when (or (memq '&optional lambda-list)
    750             (memq '&key lambda-list))
    751     (let ((state nil))
    752       (dolist (arg lambda-list)
    753         (cond ((memq arg lambda-list-keywords)
    754                (setf state arg))
    755               ((memq state '(&optional &key))
    756                (when (and (consp arg) (not (constantp (second arg))))
    757                  (compiler-unsupported
    758                   "~A: can't handle ~A argument with non-constant initform."
    759                   context
    760                   (if (eq state '&optional) "optional" "keyword")))))))))
    761 
    762 (defun p1-flet (form)
    763   (incf (compiland-children *current-compiland*) (length (cadr form)))
    764   (let ((*visible-variables* *visible-variables*)
    765         (*local-functions* *local-functions*)
    766         (*current-compiland* *current-compiland*)
    767         (local-functions '()))
    768     (dolist (definition (cadr form))
    769       (let ((name (car definition))
    770             (lambda-list (cadr definition)))
    771         (validate-name-and-lambda-list name lambda-list 'FLET)
    772         (let* ((body (cddr definition))
    773                (compiland (make-compiland :name name
    774                                           :parent *current-compiland*))
    775                (local-function (make-local-function :name name
    776                                                     :compiland compiland)))
    777           (multiple-value-bind (body decls) (parse-body body)
    778             (let* ((block-name (fdefinition-block-name name))
    779                    (lambda-expression
    780                     `(lambda ,lambda-list ,@decls (block ,block-name ,@body)))
    781                    (*visible-variables* *visible-variables*)
    782                    (*local-functions* *local-functions*)
    783                    (*current-compiland* compiland))
    784               (setf (compiland-lambda-expression compiland) lambda-expression)
    785               (setf (local-function-inline-expansion local-function)
    786                     (generate-inline-expansion block-name lambda-list body))
    787               (p1-compiland compiland)))
    788           (when *closure-variables*
    789             (let ((variable (make-variable :name (gensym))))
    790               (setf (local-function-variable local-function) variable)
    791               (push variable *all-variables*)))
    792           (push local-function local-functions))))
    793     (setf local-functions (nreverse local-functions))
    794     ;; Make the local functions visible.
    795     (dolist (local-function local-functions)
    796       (push local-function *local-functions*)
    797       (let ((variable (local-function-variable local-function)))
    798         (when variable
    799           (push variable *visible-variables*))))
    800     (with-saved-compiler-policy
    801       (process-optimization-declarations (cddr form))
    802       (list* (car form) local-functions (p1-body (cddr form))))))
    803 
    804 (defun p1-labels (form)
    805   (incf (compiland-children *current-compiland*) (length (cadr form)))
    806   (let ((*visible-variables* *visible-variables*)
    807         (*local-functions* *local-functions*)
    808         (*current-compiland* *current-compiland*)
    809         (local-functions '()))
    810     (dolist (definition (cadr form))
    811       (let ((name (car definition))
    812             (lambda-list (cadr definition)))
    813         (validate-name-and-lambda-list name lambda-list 'LABELS)
    814         (let* ((body (cddr definition))
    815                (compiland (make-compiland :name name
    816                                           :parent *current-compiland*))
    817                (variable (make-variable :name (gensym)))
    818                (local-function (make-local-function :name name
    819                                                     :compiland compiland
    820                                                     :variable variable)))
    821           (multiple-value-bind (body decls) (parse-body body)
    822             (setf (compiland-lambda-expression compiland)
    823                   `(lambda ,lambda-list ,@decls (block ,name ,@body))))
    824           (push variable *all-variables*)
    825           (push local-function local-functions))))
    826     (setf local-functions (nreverse local-functions))
    827     ;; Make the local functions visible.
    828     (dolist (local-function local-functions)
    829       (push local-function *local-functions*)
    830       (push (local-function-variable local-function) *visible-variables*))
    831     (dolist (local-function local-functions)
    832       (let ((*visible-variables* *visible-variables*)
    833             (*current-compiland* (local-function-compiland local-function)))
    834         (p1-compiland (local-function-compiland local-function))))
    835     (list* (car form) local-functions (p1-body (cddr form)))))
    836 
    837 (defknown p1-funcall (t) t)
    838 (defun p1-funcall (form)
    839   (unless (> (length form) 1)
    840     (compiler-warn "Wrong number of arguments for ~A." (car form))
    841     (return-from p1-funcall form))
    842   (let ((function-form (%cadr form)))
    843     (when (and (consp function-form)
    844                (eq (%car function-form) 'FUNCTION))
    845       (let ((name (%cadr function-form)))
    846 ;;         (format t "p1-funcall name = ~S~%" name)
    847         (let ((source-transform (source-transform name)))
    848           (when source-transform
    849 ;;             (format t "found source transform for ~S~%" name)
    850 ;;             (format t "old form = ~S~%" form)
    851 ;;             (let ((new-form (expand-source-transform form)))
    852 ;;               (when (neq new-form form)
    853 ;;                 (format t "new form = ~S~%" new-form)
    854 ;;                 (return-from p1-funcall (p1 new-form))))
    855             (let ((new-form (expand-source-transform (list* name (cddr form)))))
    856 ;;               (format t "new form = ~S~%" new-form)
    857               (return-from p1-funcall (p1 new-form)))
    858             )))))
    859   ;; Otherwise...
    860   (p1-function-call form))
    861 
    862 (defun p1-function (form)
    863   (let ((form (copy-tree form))
    864         local-function)
    865     (cond ((and (consp (cadr form))
    866                 (or (eq (caadr form) 'LAMBDA)
    867                     (eq (caadr form) 'NAMED-LAMBDA)))
    868            (let* ((named-lambda-p (eq (caadr form) 'NAMED-LAMBDA))
    869                   (named-lambda-form (when named-lambda-p
    870                                        (cadr form)))
    871                   (name (when named-lambda-p
    872                           (cadr named-lambda-form)))
    873                   (lambda-form (if named-lambda-p
    874                                    (cons 'LAMBDA (cddr named-lambda-form))
    875                                    (cadr form)))
    876                   (lambda-list (cadr lambda-form))
    877                   (body (cddr lambda-form))
    878                   (compiland (make-compiland :name (if named-lambda-p
    879                                                        name (gensym "ANONYMOUS-LAMBDA-"))
    880                                              :lambda-expression lambda-form
    881                                              :parent *current-compiland*)))
    882              (when *current-compiland*
    883                (incf (compiland-children *current-compiland*)))
    884              (multiple-value-bind (body decls)
    885                  (parse-body body)
    886                (setf (compiland-lambda-expression compiland)
    887                      (if named-lambda-p
    888                          `(lambda ,lambda-list ,@decls (block nil ,@body))
    889                          `(lambda ,lambda-list ,@decls ,@body)))
    890                (let ((*visible-variables* *visible-variables*)
    891                      (*current-compiland* compiland))
    892                  (p1-compiland compiland)))
    893              (list 'FUNCTION compiland)))
    894           ((setf local-function (find-local-function (cadr form)))
    895            (dformat t "p1-function local function ~S~%" (cadr form))
    896            (let ((variable (local-function-variable local-function)))
    897              (when variable
    898                  (dformat t "p1-function ~S used non-locally~%" (variable-name variable))
    899                  (setf (variable-used-non-locally-p variable) t)))
    900            form)
    901           (t
    902            form))))
    903 
    904 (defun p1-lambda (form)
    905   (let* ((lambda-list (cadr form))
    906          (body (cddr form))
    907          (auxvars (memq '&AUX lambda-list)))
    908     (when (or (memq '&optional lambda-list)
    909               (memq '&key lambda-list))
    910       (let ((state nil))
    911         (dolist (arg lambda-list)
    912           (cond ((memq arg lambda-list-keywords)
    913                  (setf state arg))
    914                 ((memq state '(&optional &key))
    915                  (when (and (consp arg)
    916                             (not (constantp (second arg))))
    917                    (compiler-unsupported
    918                     "P1-LAMBDA: can't handle optional argument with non-constant initform.")))))))
    919     (when auxvars
    920       (setf lambda-list (subseq lambda-list 0 (position '&AUX lambda-list)))
    921       (setf body (list (append (list 'LET* (cdr auxvars)) body))))
    922     (p1-function (list 'FUNCTION (list* 'LAMBDA lambda-list body)))))
    923 
    924 (defun p1-eval-when (form)
    925   (list* (car form) (cadr form) (mapcar #'p1 (cddr form))))
    926 
    927 (defknown p1-progv (t) t)
    928 (defun p1-progv (form)
    929   ;; We've already checked argument count in PRECOMPILE-PROGV.
    930   (let ((new-form (rewrite-progv form)))
    931     (when (neq new-form form)
    932       (return-from p1-progv (p1 new-form))))
    933   (let ((symbols-form (cadr form))
    934         (values-form (caddr form))
    935         (body (cdddr form)))
    936     `(progv ,(p1 symbols-form) ,(p1 values-form) ,@(p1-body body))))
    937 
    938 (defknown rewrite-progv (t) t)
    939 (defun rewrite-progv (form)
    940   (let ((symbols-form (cadr form))
    941         (values-form (caddr form))
    942         (body (cdddr form)))
    943     (cond ((or (unsafe-p symbols-form) (unsafe-p values-form))
    944            (let ((g1 (gensym))
    945                  (g2 (gensym)))
    946              `(let ((,g1 ,symbols-form)
    947                     (,g2 ,values-form))
    948                 (progv ,g1 ,g2 ,@body))))
    949           (t
    950            form))))
    951 
    952 (defun p1-quote (form)
    953   (unless (= (length form) 2)
    954     (compiler-error "Wrong number of arguments for special operator ~A (expected 1, but received ~D)."
    955                     'QUOTE
    956                     (1- (length form))))
    957   (let ((arg (%cadr form)))
    958     (if (or (numberp arg) (characterp arg))
    959         arg
    960         form)))
    961 
    962 (defun p1-setq (form)
    963   (unless (= (length form) 3)
    964     (error "Too many arguments for SETQ."))
    965   (let ((arg1 (%cadr form))
    966         (arg2 (%caddr form)))
    967     (let ((variable (find-visible-variable arg1)))
    968       (if variable
    969           (progn
    970             (when (variable-ignore-p variable)
    971               (compiler-style-warn
    972                "Variable ~S is assigned even though it was declared to be ignored."
    973                (variable-name variable)))
    974             (incf (variable-writes variable))
    975             (cond ((eq (variable-compiland variable) *current-compiland*)
    976                    (dformat t "p1-setq: write ~S~%" arg1))
    977                   (t
    978                    (dformat t "p1-setq: non-local write ~S~%" arg1)
    979                    (setf (variable-used-non-locally-p variable) t))))
    980           (dformat t "p1-setq: unknown variable ~S~%" arg1)))
    981     (list 'SETQ arg1 (p1 arg2))))
    982 
    983 (defun p1-the (form)
    984   (unless (= (length form) 3)
    985     (compiler-error "Wrong number of arguments for special operator ~A (expected 2, but received ~D)."
    986                     'THE
    987                     (1- (length form))))
    988   (let ((type (%cadr form))
    989         (expr (%caddr form)))
    990     (cond ((and (listp type) (eq (car type) 'VALUES))
    991            ;; FIXME
    992            (p1 expr))
    993           ((= *safety* 3)
    994            (let* ((sym (gensym))
    995                   (new-expr `(let ((,sym ,expr))
    996                                (require-type ,sym ',type)
    997                                ,sym)))
    998              (p1 new-expr)))
    999           (t
    1000            (list 'THE type (p1 expr))))))
    1001 
    1002 (defun p1-truly-the (form)
    1003   (unless (= (length form) 3)
    1004     (compiler-error "Wrong number of arguments for special operator ~A (expected 2, but received ~D)."
    1005                     'TRULY-THE
    1006                     (1- (length form))))
    1007   (list 'TRULY-THE (%cadr form) (p1 (%caddr form))))
    1008 
    1009 (defknown unsafe-p (t) t)
    1010 (defun unsafe-p (args)
    1011   (cond ((node-p args)
    1012          (unsafe-p (node-form args)))
    1013         ((atom args)
    1014          nil)
    1015         (t
    1016          (case (%car args)
    1017            (QUOTE
    1018             nil)
    1019            (LAMBDA
    1020             nil)
    1021            ((RETURN-FROM GO CATCH THROW UNWIND-PROTECT BLOCK)
    1022             t)
    1023            (t
    1024             (dolist (arg args)
    1025               (when (unsafe-p arg)
    1026                 (return t))))))))
    1027 
    1028 (defknown rewrite-throw (t) t)
    1029 (defun rewrite-throw (form)
    1030   (let ((args (cdr form)))
    1031     (if (unsafe-p args)
    1032         (let ((syms ())
    1033               (lets ()))
    1034           ;; Tag.
    1035           (let ((arg (first args)))
    1036             (if (constantp arg)
    1037                 (push arg syms)
    1038                 (let ((sym (gensym)))
    1039                   (push sym syms)
    1040                   (push (list sym arg) lets))))
    1041           ;; Result. "If the result-form produces multiple values, then all the
    1042           ;; values are saved."
    1043           (let ((arg (second args)))
    1044             (if (constantp arg)
    1045                 (push arg syms)
    1046                 (let ((sym (gensym)))
    1047                   (cond ((single-valued-p arg)
    1048                          (push sym syms)
    1049                          (push (list sym arg) lets))
    1050                         (t
    1051                          (push (list 'VALUES-LIST sym) syms)
    1052                          (push (list sym (list 'MULTIPLE-VALUE-LIST arg)) lets))))))
    1053           (list 'LET* (nreverse lets) (list* 'THROW (nreverse syms))))
    1054         form)))
    1055 
    1056 (defknown p1-throw (t) t)
    1057 (defun p1-throw (form)
    1058   (let ((new-form (rewrite-throw form)))
    1059     (when (neq new-form form)
    1060       (return-from p1-throw (p1 new-form))))
    1061   (list* 'THROW (mapcar #'p1 (cdr form))))
    1062 
    1063 (defknown rewrite-function-call (t) t)
    1064 (defun rewrite-function-call (form)
    1065   (let ((args (cdr form)))
    1066     (if (unsafe-p args)
    1067         (let ((arg1 (car args)))
    1068           (cond ((and (consp arg1) (eq (car arg1) 'GO))
    1069                  arg1)
    1070                 (t
    1071                  (let ((syms ())
    1072                        (lets ()))
    1073                    ;; Preserve the order of evaluation of the arguments!
    1074                    (dolist (arg args)
    1075                      (cond ((constantp arg)
    1076                             (push arg syms))
    1077                            ((and (consp arg) (eq (car arg) 'GO))
    1078                             (return-from rewrite-function-call
    1079                                          (list 'LET* (nreverse lets) arg)))
    1080                            (t
    1081                             (let ((sym (gensym)))
    1082                               (push sym syms)
    1083                               (push (list sym arg) lets)))))
    1084                    (list 'LET* (nreverse lets) (list* (car form) (nreverse syms)))))))
    1085         form)))
    1086 
    1087 (defknown p1-function-call (t) t)
    1088 (defun p1-function-call (form)
    1089   (let ((new-form (rewrite-function-call form)))
    1090     (when (neq new-form form)
    1091 ;;       (let ((*print-structure* nil))
    1092 ;;         (format t "old form = ~S~%" form)
    1093 ;;         (format t "new form = ~S~%" new-form))
    1094       (return-from p1-function-call (p1 new-form))))
    1095   (let* ((op (car form))
    1096          (local-function (find-local-function op)))
    1097     (cond (local-function
    1098 ;;            (format t "p1 local call to ~S~%" op)
    1099 ;;            (format t "inline-p = ~S~%" (inline-p op))
    1100 
    1101            (when (and *enable-inline-expansion* (inline-p op))
    1102              (let ((expansion (local-function-inline-expansion local-function)))
    1103                (when expansion
    1104                  (let ((explain *explain*))
    1105                    (when (and explain (memq :calls explain))
    1106                      (format t ";   inlining call to local function ~S~%" op)))
    1107                  (return-from p1-function-call (p1 (expand-inline form expansion))))))
    1108 
    1109            ;; FIXME
    1110            (dformat t "local function assumed not single-valued~%")
    1111            (setf (compiland-%single-valued-p *current-compiland*) nil)
    1112 
    1113            (let ((variable (local-function-variable local-function)))
    1114              (when variable
    1115                (dformat t "p1 ~S used non-locally~%" (variable-name variable))
    1116                (setf (variable-used-non-locally-p variable) t))))
    1117           (t
    1118            ;; Not a local function call.
    1119            (dformat t "p1 non-local call to ~S~%" op)
    1120            (unless (single-valued-p form)
    1121 ;;                (format t "not single-valued op = ~S~%" op)
    1122              (setf (compiland-%single-valued-p *current-compiland*) nil)))))
    1123   (p1-default form))
    1124 
    1125 (defknown p1 (t) t)
    1126 (defun p1 (form)
    1127   (cond ((symbolp form)
    1128          (let (value)
    1129            (cond ((null form)
    1130                   form)
    1131                  ((eq form t)
    1132                   form)
    1133                  ((keywordp form)
    1134                   form)
    1135                  ((and (constantp form)
    1136                        (progn
    1137                          (setf value (symbol-value form))
    1138                          (or (numberp value)
    1139                              (stringp value)
    1140                              (pathnamep value))))
    1141                   (setf form value))
    1142                  (t
    1143                   (let ((variable (find-visible-variable form)))
    1144                     (when (null variable)
    1145           (unless (or (special-variable-p form)
    1146                                   (memq form *undefined-variables*))
    1147       (compiler-style-warn "Undefined variable: ~S" form)
    1148       (push form *undefined-variables*))
    1149                       (setf variable (make-variable :name form :special-p t))
    1150                       (push variable *visible-variables*))
    1151                     (let ((ref (make-var-ref variable)))
    1152                       (unless (variable-special-p variable)
    1153                         (when (variable-ignore-p variable)
    1154                           (compiler-style-warn
    1155                            "Variable ~S is read even though it was declared to be ignored."
    1156                            (variable-name variable)))
    1157                         (push ref (variable-references variable))
    1158                         (incf (variable-reads variable))
    1159                         (cond ((eq (variable-compiland variable) *current-compiland*)
    1160                                (dformat t "p1: read ~S~%" form))
    1161                               (t
    1162                                (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%"
    1163                                         form
    1164                                         (compiland-name (variable-compiland variable))
    1165                                         (compiland-name *current-compiland*))
    1166                                (setf (variable-used-non-locally-p variable) t))))
    1167                       (setf form ref)))
    1168                   form))))
    1169         ((atom form)
    1170          form)
    1171         (t
    1172          (let ((op (%car form))
    1173                handler)
    1174            (cond ((symbolp op)
    1175                   (when (compiler-macro-function op)
    1176                     (unless (notinline-p op)
    1177                       (multiple-value-bind (expansion expanded-p)
    1178                           (compiler-macroexpand form)
    1179                         ;; Fall through if no change...
    1180                         (when expanded-p
    1181                           (return-from p1 (p1 expansion))))))
    1182                   (cond ((setf handler (get op 'p1-handler))
    1183                          (funcall handler form))
    1184                         ((macro-function op *compile-file-environment*)
    1185                          (p1 (macroexpand form *compile-file-environment*)))
    1186                         ((special-operator-p op)
    1187                          (compiler-unsupported "P1: unsupported special operator ~S" op))
    1188                         (t
    1189                          (p1-function-call form))))
    1190                  ((and (consp op) (eq (%car op) 'LAMBDA))
    1191                   (p1 (list* 'FUNCALL form)))
    1192                  (t
    1193                   form))))))
    1194 
    1195 (defun install-p1-handler (symbol handler)
    1196   (setf (get symbol 'p1-handler) handler))
    1197 
    1198 (defun initialize-p1-handlers ()
    1199   (dolist (pair '((AND                  p1-default)
    1200                   (BLOCK                p1-block)
    1201                   (CATCH                p1-catch)
    1202                   (DECLARE              identity)
    1203                   (EVAL-WHEN            p1-eval-when)
    1204                   (FLET                 p1-flet)
    1205                   (FUNCALL              p1-funcall)
    1206                   (FUNCTION             p1-function)
    1207                   (GO                   p1-go)
    1208                   (IF                   p1-if)
    1209                   (LABELS               p1-labels)
    1210                   (LAMBDA               p1-lambda)
    1211                   (LET                  p1-let/let*)
    1212                   (LET*                 p1-let/let*)
    1213                   (LOAD-TIME-VALUE      identity)
    1214                   (LOCALLY              p1-locally)
    1215                   (MULTIPLE-VALUE-BIND  p1-m-v-b)
    1216                   (MULTIPLE-VALUE-CALL  p1-default)
    1217                   (MULTIPLE-VALUE-LIST  p1-default)
    1218                   (MULTIPLE-VALUE-PROG1 p1-default)
    1219                   (OR                   p1-default)
    1220                   (PROGN                p1-default)
    1221                   (PROGV                p1-progv)
    1222                   (QUOTE                p1-quote)
    1223                   (RETURN-FROM          p1-return-from)
    1224                   (SETQ                 p1-setq)
    1225                   (SYMBOL-MACROLET      identity)
    1226                   (TAGBODY              p1-tagbody)
    1227                   (THE                  p1-the)
    1228                   (THROW                p1-throw)
    1229                   (TRULY-THE            p1-truly-the)
    1230                   (UNWIND-PROTECT       p1-unwind-protect)))
    1231     (install-p1-handler (%car pair) (%cadr pair))))
    1232 
    1233 (initialize-p1-handlers)
    1234 
    1235 (defun dump-pool ()
    1236   (let ((pool (reverse *pool*))
    1237         entry type)
    1238     (dotimes (index (1- *pool-count*))
    1239       (setq entry (car pool))
    1240       (setq type (case (car entry)
    1241                    (7 'class)
    1242                    (9 'field)
    1243                    (10 'method)
    1244                    (11 'interface)
    1245                    (8 'string)
    1246                    (3 'integer)
    1247                    (4 'float)
    1248                    (5 'long)
    1249                    (6 'double)
    1250                    (12 'name-and-type)
    1251                    (1 'utf8)))
    1252       (format t "~D: ~A ~S~%" (1+ index) type entry)
    1253       (setq pool (cdr pool))))
    1254   t)
    1255 
    1256 (defknown pool-get (t) (integer 1 65535))
    1257 (defun pool-get (entry)
    1258   (declare (optimize speed (safety 0)))
    1259   (let* ((ht *pool-entries*)
    1260          (index (gethash1 entry ht)))
    1261     (declare (type hash-table ht))
    1262     (unless index
    1263       (setf index *pool-count*)
    1264       (push entry *pool*)
    1265       (setf (gethash entry ht) index)
    1266       (setf *pool-count* (1+ index)))
    1267     index))
    1268 
    1269 (declaim (ftype (function (string) fixnum) pool-name))
    1270 (declaim (inline pool-name))
    1271 (defun pool-name (name)
    1272   (declare (optimize speed))
    1273   (pool-get (list 1 (length name) name)))
    1274 
    1275 (declaim (ftype (function (string string) fixnum) pool-name-and-type))
    1276 (declaim (inline pool-name-and-type))
    1277 (defun pool-name-and-type (name type)
    1278   (declare (optimize speed))
    1279   (pool-get (list 12
    1280                   (pool-name name)
    1281                   (pool-name type))))
    1282 
    1283 ;; Assumes CLASS-NAME is already in the correct form ("org/armedbear/lisp/Lisp"
    1284 ;; as opposed to "org.armedbear.lisp.Lisp").
    1285 (declaim (ftype (function (string) fixnum) pool-class))
    1286 (declaim (inline pool-class))
    1287 (defun pool-class (class-name)
    1288   (declare (optimize speed))
    1289   (pool-get (list 7 (pool-name class-name))))
    1290 
    1291 ;; (tag class-index name-and-type-index)
    1292 (declaim (ftype (function (string string string) fixnum) pool-field))
    1293 (declaim (inline pool-field))
    1294 (defun pool-field (class-name field-name type-name)
    1295   (declare (optimize speed))
    1296   (pool-get (list 9
    1297                   (pool-class class-name)
    1298                   (pool-name-and-type field-name type-name))))
    1299 
    1300 ;; (tag class-index name-and-type-index)
    1301 (declaim (ftype (function (string string string) fixnum) pool-method))
    1302 (declaim (inline pool-method))
    1303 (defun pool-method (class-name method-name type-name)
    1304   (declare (optimize speed))
    1305   (pool-get (list 10
    1306                   (pool-class class-name)
    1307                   (pool-name-and-type method-name type-name))))
    1308 
    1309 (declaim (ftype (function (string) fixnum) pool-string))
    1310 (defun pool-string (string)
    1311   (declare (optimize speed))
    1312   (pool-get (list 8 (pool-name string))))
    1313 
    1314 (defknown pool-int (fixnum) (integer 1 65535))
    1315 (defun pool-int (n)
    1316   (declare (optimize speed))
    1317   (pool-get (list 3 n)))
    1318 
    1319 (defknown pool-long (integer) (integer 1 65535))
    1320 (defun pool-long (n)
    1321   (declare (optimize speed))
    1322   (declare (type java-long n))
    1323   (let* ((entry (list 5
    1324                       (logand (ash n -32) #xffffffff)
    1325                       (logand n #xffffffff)))
    1326          (ht *pool-entries*)
    1327          (index (gethash1 entry ht)))
    1328     (declare (type hash-table ht))
    1329     (unless index
    1330       (setf index *pool-count*)
    1331       (push entry *pool*)
    1332       (setf (gethash entry ht) index)
    1333       ;; The Java Virtual Machine Specification, Section 4.4.5: "All 8-byte
    1334       ;; constants take up two entries in the constant_pool table of the class
    1335       ;; file. If a CONSTANT_Long_info or CONSTANT_Double_info structure is the
    1336       ;; item in the constant_pool table at index n, then the next usable item in
    1337       ;; the pool is located at index n+2. The constant_pool index n+1 must be
    1338       ;; valid but is considered unusable." So:
    1339       (setf *pool-count* (+ index 2)))
    1340     index))
    1341 
    1342 (defknown u2 (fixnum) cons)
    1343 (defun u2 (n)
    1344   (declare (optimize speed))
    1345   (declare (type (unsigned-byte 16) n))
    1346   (list (logand (ash n -8) #xff)
    1347         (logand n #xff)))
    1348 
    1349 (defconstant +java-string+ "Ljava/lang/String;")
    1350 (defconstant +lisp-class+ "org/armedbear/lisp/Lisp")
    1351 (defconstant +lisp-class-class+ "org/armedbear/lisp/LispClass")
    1352 (defconstant +lisp-object-class+ "org/armedbear/lisp/LispObject")
    1353 (defconstant +lisp-object+ "Lorg/armedbear/lisp/LispObject;")
    1354 (defconstant +lisp-object-array+ "[Lorg/armedbear/lisp/LispObject;")
    1355 (defconstant +lisp-symbol-class+ "org/armedbear/lisp/Symbol")
    1356 (defconstant +lisp-symbol+ "Lorg/armedbear/lisp/Symbol;")
    1357 (defconstant +lisp-structure-object-class+ "org/armedbear/lisp/StructureObject")
    1358 (defconstant +lisp-thread-class+ "org/armedbear/lisp/LispThread")
    1359 (defconstant +lisp-thread+ "Lorg/armedbear/lisp/LispThread;")
    1360 (defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons")
    1361 (defconstant +lisp-cons+ "Lorg/armedbear/lisp/Cons;")
    1362 (defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum")
    1363 (defconstant +lisp-fixnum+ "Lorg/armedbear/lisp/Fixnum;")
    1364 (defconstant +lisp-fixnum-array+ "[Lorg/armedbear/lisp/Fixnum;")
    1365 (defconstant +lisp-bignum-class+ "org/armedbear/lisp/Bignum")
    1366 (defconstant +lisp-bignum+ "Lorg/armedbear/lisp/Bignum;")
    1367 (defconstant +lisp-character-class+ "org/armedbear/lisp/LispCharacter")
    1368 (defconstant +lisp-character+ "Lorg/armedbear/lisp/LispCharacter;")
    1369 (defconstant +lisp-character-array+ "[Lorg/armedbear/lisp/LispCharacter;")
    1370 (defconstant +lisp-abstract-bit-vector-class+ "org/armedbear/lisp/AbstractBitVector")
    1371 (defconstant +lisp-abstract-vector-class+ "org/armedbear/lisp/AbstractVector")
    1372 (defconstant +lisp-abstract-string-class+ "org/armedbear/lisp/AbstractString")
    1373 (defconstant +lisp-simple-vector-class+ "org/armedbear/lisp/SimpleVector")
    1374 (defconstant +lisp-simple-string-class+ "org/armedbear/lisp/SimpleString")
    1375 (defconstant +lisp-simple-string+ "Lorg/armedbear/lisp/SimpleString;")
    1376 (defconstant +lisp-environment+ "Lorg/armedbear/lisp/Environment;")
    1377 (defconstant +lisp-special-binding+ "Lorg/armedbear/lisp/SpecialBinding;")
    1378 (defconstant +lisp-throw-class+ "org/armedbear/lisp/Throw")
    1379 (defconstant +lisp-return-class+ "org/armedbear/lisp/Return")
    1380 (defconstant +lisp-go-class+ "org/armedbear/lisp/Go")
    1381 (defconstant +lisp-ctf-class+ "org/armedbear/lisp/ClosureTemplateFunction")
    1382 (defconstant +lisp-compiled-closure-class+ "org/armedbear/lisp/CompiledClosure")
    1383 (defconstant +lisp-compiled-function-class+ "org/armedbear/lisp/CompiledFunction")
    1384 (defconstant +lisp-primitive-class+ "org/armedbear/lisp/Primitive")
    1385 (defconstant +lisp-hash-table-class+ "org/armedbear/lisp/HashTable")
    1386 (defconstant +lisp-eql-hash-table-class+ "org/armedbear/lisp/EqlHashTable")
    1387 (defconstant +lisp-package-class+ "org/armedbear/lisp/Package")
    1388 (defconstant +lisp-readtable-class+ "org/armedbear/lisp/Readtable")
    1389 (defconstant +lisp-stream-class+ "org/armedbear/lisp/Stream")
    1390 
    1391 (defstruct (instruction (:constructor make-instruction (opcode args)))
    1392   (opcode 0 :type (integer 0 255))
    1393   args
    1394   stack
    1395   depth)
    1396 
    1397 (defun print-instruction (instruction)
    1398   (sys::%format nil "~A ~A stack = ~S depth = ~S"
    1399           (opcode-name (instruction-opcode instruction))
    1400           (instruction-args instruction)
    1401           (instruction-stack instruction)
    1402           (instruction-depth instruction)))
    1403 
    1404 (defknown inst * t)
    1405 (defun inst (instr &optional args)
    1406   (declare (optimize speed))
    1407   (let ((opcode (if (fixnump instr)
    1408                     instr
    1409                     (opcode-number instr))))
    1410     (unless (listp args)
    1411       (setf args (list args)))
    1412     (make-instruction opcode args)))
    1413 
    1414 (defknown %%emit * t)
    1415 (defun %%emit (instr &rest args)
    1416   (declare (optimize speed))
    1417   (let ((instruction (make-instruction instr args)))
    1418     (push instruction *code*)
    1419     instruction))
    1420 
    1421 (defknown %emit * t)
    1422 (defun %emit (instr &rest args)
    1423   (declare (optimize speed))
    1424   (let ((instruction (inst instr args)))
    1425     (push instruction *code*)
    1426     instruction))
    1427 
    1428 (defmacro emit (instr &rest args)
    1429   (when (and (consp instr) (eq (car instr) 'QUOTE) (symbolp (cadr instr)))
    1430     (setf instr (opcode-number (cadr instr))))
    1431   (if (fixnump instr)
    1432       `(%%emit ,instr ,@args)
    1433       `(%emit ,instr ,@args)))
    1434 
    1435 (defknown label (symbol) t)
    1436 (defun label (symbol)
    1437   (declare (type symbol symbol))
    1438   (declare (optimize speed))
    1439   (emit 'label symbol)
    1440   (setf (symbol-value symbol) nil))
    1441 
    1442 (defknown emit-push-nil () t)
    1443 (declaim (inline emit-push-nil))
    1444 (defun emit-push-nil ()
    1445   (emit 'getstatic +lisp-class+ "NIL" +lisp-object+))
    1446 
    1447 (defknown emit-push-t () t)
    1448 (declaim (inline emit-push-t))
    1449 (defun emit-push-t ()
    1450   (emit 'getstatic +lisp-class+ "T" +lisp-symbol+))
    1451 
    1452 (defknown emit-push-false (t) t)
    1453 (defun emit-push-false (representation)
    1454   (declare (optimize speed (safety 0)))
    1455   (case representation
    1456     (:boolean
    1457      (emit 'iconst_0))
    1458     (t
    1459      (emit-push-nil))))
    1460 
    1461 (defknown emit-push-true (t) t)
    1462 (defun emit-push-true (representation)
    1463   (declare (optimize speed (safety 0)))
    1464   (case representation
    1465     (:boolean
    1466      (emit 'iconst_1))
    1467     (t
    1468      (emit-push-t))))
    1469 
    1470 (defknown emit-push-constant-int (fixnum) t)
    1471 (defun emit-push-constant-int (n)
    1472   (if (<= -32768 n 32767)
    1473       (emit 'sipush n)
    1474       (emit 'ldc (pool-int n))))
    1475 
    1476 (defknown emit-push-constant-long (integer) t)
    1477 (defun emit-push-constant-long (n)
    1478   (emit 'ldc2_w (pool-long n)))
    1479 
    1480 (declaim (ftype (function (t t) cons) make-descriptor-info))
    1481 (defun make-descriptor-info (arg-types return-type)
    1482   (let ((descriptor (with-standard-io-syntax
    1483                       (with-output-to-string (s)
    1484                         (princ #\( s)
    1485                         (dolist (type arg-types)
    1486                           (princ type s))
    1487                         (princ #\) s)
    1488                         (princ (or return-type "V") s))))
    1489         (stack-effect (let ((result (cond ((null return-type) 0)
    1490                                           ((equal return-type "J") 2)
    1491                                           (t 1))))
    1492                         (dolist (type arg-types result)
    1493                           (decf result (if (equal type "J") 2 1))))))
    1494     (cons descriptor stack-effect)))
    1495 
    1496 (defparameter *descriptors* (make-hash-table :test #'equal))
    1497 
    1498 (declaim (ftype (function (t t) cons) get-descriptor-info))
    1499 (defun get-descriptor-info (arg-types return-type)
    1500   (let* ((key (list arg-types return-type))
    1501          (ht *descriptors*)
    1502          (descriptor-info (gethash1 key ht)))
    1503     (declare (type hash-table ht))
    1504     (or descriptor-info
    1505         (setf (gethash key ht) (make-descriptor-info arg-types return-type)))))
    1506 
    1507 (defsubst get-descriptor (arg-types return-type)
    1508   (car (get-descriptor-info arg-types return-type)))
    1509 
    1510 (declaim (ftype (function * t) emit-invokestatic))
    1511 (defun emit-invokestatic (class-name method-name arg-types return-type)
    1512   (let* ((info (get-descriptor-info arg-types return-type))
    1513          (descriptor (car info))
    1514          (stack-effect (cdr info))
    1515          (instruction (emit 'invokestatic class-name method-name descriptor)))
    1516     (setf (instruction-stack instruction) stack-effect)))
    1517 
    1518 (defknown pretty-java-type (t) string)
    1519 (defun pretty-java-type (type)
    1520   (let ((arrayp nil)
    1521         (pretty-string nil))
    1522     (when (and (stringp type)
    1523                (> (length type) 0)
    1524                (char= (char type 0) #\[))
    1525       (setf arrayp t
    1526             type (subseq type 1)))
    1527     (setf pretty-string
    1528           (cond ((equal type +lisp-object+)
    1529                  "LispObject")
    1530                 ((equal type +lisp-symbol+)
    1531                  "Symbol")
    1532                 ((equal type +lisp-thread+)
    1533                  "LispThread")
    1534                 ((equal type "C")
    1535                  "char")
    1536                 ((equal type "I")
    1537                  "int")
    1538                 ((equal type "Z")
    1539                  "boolean")
    1540                 ((null type)
    1541                  "void")
    1542                 (t
    1543                  type)))
    1544     (when arrayp
    1545       (setf pretty-string (concatenate 'string pretty-string "[]")))
    1546     pretty-string))
    1547 
    1548 (declaim (ftype (function t string) pretty-java-class))
    1549 (defun pretty-java-class (class)
    1550   (cond ((equal class +lisp-object-class+)
    1551          "LispObject")
    1552         ((equal class +lisp-symbol+)
    1553          "Symbol")
    1554         ((equal class +lisp-thread-class+)
    1555          "LispThread")
    1556         (t
    1557          class)))
    1558 
    1559 (defknown emit-invokevirtual (t t t t) t)
    1560 (defun emit-invokevirtual (class-name method-name arg-types return-type)
    1561   (let* ((info (get-descriptor-info arg-types return-type))
    1562          (descriptor (car info))
    1563          (stack-effect (cdr info))
    1564          (instruction (emit 'invokevirtual class-name method-name descriptor)))
    1565     (declare (type (signed-byte 8) stack-effect))
    1566     (let ((explain *explain*))
    1567       (when (and explain (memq :java-calls explain))
    1568         (unless (string= method-name "execute")
    1569           (format t ";   call to ~A ~A.~A(~{~A~^,~})~%"
    1570                   (pretty-java-type return-type)
    1571                   (pretty-java-class class-name)
    1572                   method-name
    1573                   (mapcar 'pretty-java-type arg-types)))))
    1574     (setf (instruction-stack instruction) (1- stack-effect))))
    1575 
    1576 (defknown emit-invokespecial-init (string list) t)
    1577 (defun emit-invokespecial-init (class-name arg-types)
    1578   (let* ((info (get-descriptor-info arg-types nil))
    1579          (descriptor (car info))
    1580          (stack-effect (cdr info))
    1581          (instruction (emit 'invokespecial class-name "<init>" descriptor)))
    1582     (declare (type (signed-byte 8) stack-effect))
    1583     (setf (instruction-stack instruction) (1- stack-effect))))
    1584 
    1585 ;; Index of local variable used to hold the current thread.
    1586 (defvar *thread* nil)
    1587 
    1588 (defvar *initialize-thread-var* nil)
    1589 
    1590 (defun maybe-initialize-thread-var ()
    1591   (when *initialize-thread-var*
    1592     (emit-invokestatic +lisp-thread-class+ "currentThread" nil +lisp-thread+)
    1593     (emit 'astore *thread*)
    1594     (setf *initialize-thread-var* nil)))
    1595 
    1596 (defknown ensure-thread-var-initialized () t)
    1597 (declaim (inline ensure-thread-var-initialized))
    1598 (defun ensure-thread-var-initialized ()
    1599   (setf *initialize-thread-var* t))
    1600 
    1601 (defknown emit-push-current-thread () t)
    1602 (defun emit-push-current-thread ()
    1603   (declare (optimize speed))
    1604   (ensure-thread-var-initialized)
    1605   (emit 'aload *thread*))
    1606 
    1607 (defknown generate-instanceof-type-check-for-variable (t t) t)
    1608 (defun generate-instanceof-type-check-for-variable (variable expected-type)
    1609   (declare (type symbol expected-type))
    1610   (let ((instanceof-class (ecase expected-type
    1611                             (SYMBOL     +lisp-symbol-class+)
    1612                             (CHARACTER  +lisp-character-class+)
    1613                             (CONS       +lisp-cons-class+)
    1614                             (HASH-TABLE +lisp-hash-table-class+)
    1615                             (FIXNUM     +lisp-fixnum-class+)
    1616                             (STREAM     +lisp-stream-class+)
    1617                             (STRING     +lisp-abstract-string-class+)
    1618                             (VECTOR     +lisp-abstract-vector-class+)))
    1619         (expected-type-java-symbol-name (case expected-type
    1620                                           (HASH-TABLE "HASH_TABLE")
    1621                                           (t
    1622                                            (symbol-name expected-type))))
    1623         (LABEL1 (gensym))
    1624         register
    1625         index)
    1626     (cond ((setf register (variable-register variable))
    1627            (emit 'aload register)
    1628            (emit 'instanceof instanceof-class)
    1629            (emit 'ifne LABEL1)
    1630            (emit 'aload register)) ; datum
    1631           ((setf index (variable-index variable))
    1632            (let ((argument-register (compiland-argument-register *current-compiland*)))
    1633              (aver (not (null argument-register)))
    1634              (emit 'aload argument-register)
    1635              (emit-push-constant-int index)
    1636              (emit 'aaload)
    1637              (emit 'instanceof instanceof-class)
    1638              (emit 'ifne LABEL1)
    1639              (emit 'aload argument-register)
    1640              (emit-push-constant-int index)
    1641              (emit 'aaload))) ; datum
    1642           (t
    1643            (return-from generate-instanceof-type-check-for-variable)))
    1644     (emit 'getstatic +lisp-symbol-class+ expected-type-java-symbol-name +lisp-symbol+)
    1645     (emit-invokestatic +lisp-class+ "type_error"
    1646                        (lisp-object-arg-types 2) +lisp-object+)
    1647     (emit 'pop) ; Needed for JVM stack consistency.
    1648     (label LABEL1))
    1649   t)
    1650 
    1651 (defknown generate-type-check-for-variable (t) t)
    1652 (defun generate-type-check-for-variable (variable)
    1653   (let ((declared-type (variable-declared-type variable)))
    1654     (cond ((eq declared-type :none)) ; Nothing to do.
    1655           ((eq declared-type 'SYMBOL)
    1656            (generate-instanceof-type-check-for-variable variable 'SYMBOL))
    1657           ((eq declared-type 'CHARACTER)
    1658            (generate-instanceof-type-check-for-variable variable 'CHARACTER))
    1659           ((eq declared-type 'CONS)
    1660            (generate-instanceof-type-check-for-variable variable 'CONS))
    1661           ((eq declared-type 'HASH-TABLE)
    1662            (generate-instanceof-type-check-for-variable variable 'HASH-TABLE))
    1663           ((fixnum-type-p declared-type)
    1664            (generate-instanceof-type-check-for-variable variable 'FIXNUM))
    1665           ((subtypep declared-type 'STRING)
    1666            (generate-instanceof-type-check-for-variable variable 'STRING))
    1667           ((subtypep declared-type 'VECTOR)
    1668            (generate-instanceof-type-check-for-variable variable 'VECTOR))
    1669           ((eq declared-type 'STREAM)
    1670            (generate-instanceof-type-check-for-variable variable 'STREAM))
    1671           (t
    1672            nil))))
    1673 
    1674 (defknown maybe-generate-type-check (t) t)
    1675 (defun maybe-generate-type-check (variable)
    1676   (unless (or (zerop *safety*)
    1677               (variable-special-p variable)
    1678               (eq (variable-representation variable) :int))
    1679     (let ((declared-type (variable-declared-type variable)))
    1680       (unless (eq declared-type :none)
    1681         (unless (subtypep (derive-type (variable-initform variable)) declared-type)
    1682           (generate-type-check-for-variable variable))))))
    1683 
    1684 (defknown generate-type-checks-for-variables (list) t)
    1685 (defun generate-type-checks-for-variables (variables)
    1686   (unless (zerop *safety*)
    1687     (dolist (variable variables)
    1688       (unless (variable-special-p variable)
    1689         (generate-type-check-for-variable variable)))
    1690     t))
    1691 
    1692 (defun generate-arg-count-check (arity)
    1693   (aver (fixnump arity))
    1694   (aver (not (minusp arity)))
    1695   (aver (not (null (compiland-argument-register *current-compiland*))))
    1696   (let ((label1 (gensym)))
    1697     (emit 'aload (compiland-argument-register *current-compiland*))
    1698     (emit 'arraylength)
    1699     (emit 'bipush arity)
    1700     (emit 'if_icmpeq `,label1)
    1701     (emit 'aload 0) ; this
    1702     (emit-invokevirtual *this-class* "argCountError" nil nil)
    1703     (emit 'label `,label1)))
    1704 
    1705 (defun maybe-generate-interrupt-check ()
    1706   (unless (> *speed* *safety*)
    1707     (let ((label1 (gensym)))
    1708       (emit 'getstatic +lisp-class+ "interrupted" "Z")
    1709       (emit 'ifeq `,label1)
    1710       (emit-invokestatic +lisp-class+ "handleInterrupt" nil nil)
    1711       (emit 'label `,label1))))
    1712 
    1713 (defknown single-valued-p (t) t)
    1714 (defun single-valued-p (form)
    1715   (cond ((block-node-p form)
    1716          (if (equal (block-name form) '(TAGBODY))
    1717              (not (unsafe-p (node-form form)))
    1718              (single-valued-p (node-form form))))
    1719         ((var-ref-p form)
    1720          t)
    1721         ((atom form)
    1722          t)
    1723         (t
    1724          (let ((op (%car form))
    1725                result-type
    1726                compiland)
    1727            (cond ((eq op 'IF)
    1728                   (and (single-valued-p (third form))
    1729                        (single-valued-p (fourth form))))
    1730                  ((eq op 'PROGN)
    1731                   (single-valued-p (car (last form))))
    1732                  ((eq op 'BLOCK)
    1733                   (single-valued-p (car (last form))))
    1734                  ((memq op '(LET LET*))
    1735                   (single-valued-p (car (last (cddr form)))))
    1736                  ((memq op '(AND OR))
    1737                   (every #'single-valued-p (cdr form)))
    1738                  ((eq op 'RETURN-FROM)
    1739                   (single-valued-p (third form)))
    1740                  ((memq op '(THE TRULY-THE))
    1741                   (single-valued-p (third form)))
    1742                  ((setf result-type
    1743                         (or (function-result-type op)
    1744                             (and (proclaimed-ftype op)
    1745                                  (ftype-result-type (proclaimed-ftype op)))))
    1746                   (cond ((eq result-type '*)
    1747                          nil)
    1748                         ((atom result-type)
    1749                          t)
    1750                         ((eq (%car result-type) 'VALUES)
    1751                          (= (length result-type) 2))
    1752                         (t
    1753                          t)))
    1754                  ((and (setf compiland *current-compiland*)
    1755                        (eq op (compiland-name compiland)))
    1756                   (compiland-%single-valued-p compiland))
    1757                  (t
    1758                   nil))))))
    1759 
    1760 (defknown emit-clear-values () t)
    1761 (defun emit-clear-values ()
    1762   (declare (optimize speed (safety 0)))
    1763   (ensure-thread-var-initialized)
    1764   (emit 'clear-values))
    1765 
    1766 (defknown maybe-emit-clear-values (&rest t) t)
    1767 (defun maybe-emit-clear-values (&rest forms)
    1768   (declare (optimize speed))
    1769   (dolist (form forms)
    1770     (unless (single-valued-p form)
    1771 ;;       (let ((*print-structure* nil))
    1772 ;;         (format t "Not single-valued: ~S~%" form))
    1773       (ensure-thread-var-initialized)
    1774       (emit 'clear-values)
    1775       (return))))
    1776 
    1777 (defknown emit-unbox-fixnum () t)
    1778 (defun emit-unbox-fixnum ()
    1779   (declare (optimize speed))
    1780   (cond ((= *safety* 3)
    1781          (emit-invokestatic +lisp-fixnum-class+ "getValue"
    1782                             (lisp-object-arg-types 1) "I"))
    1783         (t
    1784          (emit 'checkcast +lisp-fixnum-class+)
    1785          (emit 'getfield +lisp-fixnum-class+ "value" "I"))))
    1786 
    1787 (defknown emit-unbox-character () t)
    1788 (defun emit-unbox-character ()
    1789   (cond ((> *safety* 0)
    1790          (emit-invokestatic +lisp-character-class+ "getValue"
    1791                             (lisp-object-arg-types 1) "C"))
    1792         (t
    1793          (emit 'checkcast +lisp-character-class+)
    1794          (emit 'getfield +lisp-character-class+ "value" "C"))))
    1795 
    1796 (defknown emit-unbox-boolean () t)
    1797 (defun emit-unbox-boolean ()
    1798   (let ((LABEL1 (gensym))
    1799         (LABEL2 (gensym)))
    1800     (emit-push-nil)
    1801     (emit 'if_acmpeq LABEL1)
    1802     (emit 'iconst_1)
    1803     (emit 'goto LABEL2)
    1804     (label LABEL1)
    1805     (emit 'iconst_0)
    1806     (label LABEL2)))
    1807 
    1808 (defknown fix-boxing (t t) t)
    1809 (defun fix-boxing (required-representation derived-type)
    1810   "Generate code to convert a boxed LispObject on the stack to the specified
    1811 representation, based on the derived type of the LispObject."
    1812   (cond ((null required-representation)) ; Nothing to do.
    1813         ((eq required-representation :int)
    1814          (cond ((and (fixnum-type-p derived-type)
    1815                      (< *safety* 3))
    1816                 (emit 'checkcast +lisp-fixnum-class+)
    1817                 (emit 'getfield +lisp-fixnum-class+ "value" "I"))
    1818                (t
    1819                 (emit-invokevirtual +lisp-object-class+ "intValue" nil "I"))))
    1820         ((eq required-representation :char)
    1821          (emit-unbox-character))
    1822         ((eq required-representation :boolean)
    1823          (emit-unbox-boolean))
    1824         ((eq required-representation :long)
    1825          (emit-invokevirtual +lisp-object-class+ "longValue" nil "J"))))
    1826 
    1827 (defknown emit-box-long () t)
    1828 (defun emit-box-long ()
    1829   (declare (optimize speed))
    1830   (emit-invokestatic +lisp-class+ "number" '("J") +lisp-object+))
    1831 
    1832 (defknown convert-long (t) t)
    1833 (defun convert-long (representation)
    1834   (case representation
    1835     (:int
    1836      (emit 'l2i))
    1837     (:long)
    1838     (t
    1839      (emit-box-long))))
    1840 
    1841 (defknown emit-box-boolean () t)
    1842 (defun emit-box-boolean ()
    1843   (let ((LABEL1 (gensym))
    1844         (LABEL2 (gensym)))
    1845     (emit 'ifeq LABEL1)
    1846     (emit-push-t)
    1847     (emit 'goto LABEL2)
    1848     (label LABEL1)
    1849     (emit-push-nil)
    1850     (label LABEL2)))
    1851 
    1852 (defknown emit-move-from-stack (t &optional t) t)
    1853 (defun emit-move-from-stack (target &optional representation)
    1854   (declare (optimize speed))
    1855   (cond ((null target)
    1856          (emit 'pop))
    1857         ((eq target 'stack)) ; Nothing to do.
    1858         ((fixnump target)
    1859          ;; A register.
    1860          (emit
    1861           (case representation
    1862             ((:int :boolean :char)
    1863              'istore)
    1864             (:long
    1865              'lstore)
    1866             (t
    1867              'astore))
    1868           target))
    1869         (t
    1870          (aver nil))))
    1871 
    1872 ;; Expects value on stack.
    1873 (defknown emit-invoke-method (t t t) t)
    1874 (defun emit-invoke-method (method-name target representation)
    1875   (emit-invokevirtual +lisp-object-class+ method-name nil +lisp-object+)
    1876   (fix-boxing representation nil)
    1877   (emit-move-from-stack target representation))
    1878 
    1879 (defvar *style-warnings* nil)
    1880 (defvar *warnings* nil)
    1881 (defvar *errors* nil)
    1882 
    1883 (defvar *last-error-context* nil)
    1884 
    1885 (defun note-error-context ()
    1886   (let ((context *compiler-error-context*))
    1887     (when (and context (neq context *last-error-context*))
    1888       (fresh-line *error-output*)
    1889       (princ "; in " *error-output*)
    1890       (let ((*print-length* 2)
    1891             (*print-level* 2)
    1892             (*print-pretty* nil))
    1893         (prin1 context *error-output*))
    1894       (terpri *error-output*)
    1895       (terpri *error-output*)
    1896       (setf *last-error-context* context))))
    1897 
    1898 (defvar *resignal-compiler-warnings* nil) ; bind this to t inside slime compilation
    1899 
    1900 (defun handle-style-warning (condition)
    1901   (cond (*resignal-compiler-warnings*
    1902          (signal condition))
    1903         (t
    1904          (unless *suppress-compiler-warnings*
    1905            (fresh-line *error-output*)
    1906            (note-error-context)
    1907            (format *error-output* "; Caught ~A:~%;   ~A~2%" (type-of condition) condition))
    1908          (incf *style-warnings*)
    1909          (muffle-warning))))
    1910 
    1911 (defun handle-warning (condition)
    1912   (cond (*resignal-compiler-warnings*
    1913          (signal condition))
    1914         (t
    1915          (unless *suppress-compiler-warnings*
    1916            (fresh-line *error-output*)
    1917            (note-error-context)
    1918            (format *error-output* "; Caught ~A:~%;   ~A~2%" (type-of condition) condition))
    1919          (incf *warnings*)
    1920          (muffle-warning))))
    1921 
    1922 (defun handle-compiler-error (condition)
    1923   (fresh-line *error-output*)
    1924   (note-error-context)
    1925   (format *error-output* "; Caught ERROR:~%;   ~A~2%" condition)
    1926   (incf *errors*)
    1927   (throw 'compile-defun-abort (funcall *compiler-error-bailout*)))
    1928 
    1929 ;; "In addition to situations for which the standard specifies that conditions
    1930 ;; of type WARNING must or might be signaled, warnings might be signaled in
    1931 ;; situations where the compiler can determine that the consequences are
    1932 ;; undefined or that a run-time error will be signaled. Examples of this
    1933 ;; situation are as follows: violating type declarations, altering or assigning
    1934 ;; the value of a constant defined with DEFCONSTANT, calling built-in Lisp
    1935 ;; functions with a wrong number of arguments or malformed keyword argument
    1936 ;; lists, and using unrecognized declaration specifiers." (3.2.5)
    1937 (defknown check-arg-count (t fixnum) t)
    1938 (defun check-arg-count (form n)
    1939   (declare (type fixnum n))
    1940   (let* ((op (car form))
    1941          (args (cdr form))
    1942          (ok (= (length args) n)))
    1943     (declare (type boolean ok))
    1944     (unless ok
    1945       (funcall (if (eq (symbol-package op) +cl-package+)
    1946                    #'compiler-warn ; See above!
    1947                    #'compiler-style-warn)
    1948                "Wrong number of arguments for ~A (expected ~D, but received ~D)."
    1949                op n (length args)))
    1950     ok))
    1951 
    1952 (declaim (ftype (function (t fixnum) t) check-min-args))
    1953 (defun check-min-args (form n)
    1954   (declare (type fixnum n))
    1955   (let* ((op (car form))
    1956          (args (cdr form))
    1957          (ok (>= (length args) n)))
    1958     (unless ok
    1959       (funcall (if (eq (symbol-package op) +cl-package+)
    1960                    #'compiler-warn ; See above!
    1961                    #'compiler-style-warn)
    1962                "Wrong number of arguments for ~A (expected at least ~D, but received ~D)."
    1963                op n (length args)))
    1964     ok))
    1965 
    1966 (defun unsupported-opcode (instruction)
    1967   (error "Unsupported opcode ~D." (instruction-opcode instruction)))
    1968 
    1969 (declaim (type hash-table +resolvers+))
    1970 (defconst +resolvers+ (make-hash-table))
    1971 
    1972 (defun initialize-resolvers ()
    1973   (let ((ht +resolvers+))
    1974     (dotimes (n (1+ *last-opcode*))
    1975       (setf (gethash n ht) #'unsupported-opcode))
    1976     ;; The following opcodes resolve to themselves.
    1977     (dolist (n '(0 ; nop
    1978                  1 ; aconst_null
    1979                  2 ; iconst_m1
    1980                  3 ; iconst_0
    1981                  4 ; iconst_1
    1982                  5 ; iconst_2
    1983                  6 ; iconst_3
    1984                  7 ; iconst_4
    1985                  8 ; iconst_5
    1986                  9 ; lconst_0
    1987                  10 ; lconst_1
    1988                  42 ; aload_0
    1989                  43 ; aload_1
    1990                  44 ; aload_2
    1991                  45 ; aload_3
    1992                  50 ; aaload
    1993                  75 ; astore_0
    1994                  76 ; astore_1
    1995                  77 ; astore_2
    1996                  78 ; astore_3
    1997                  83 ; aastore
    1998                  87 ; pop
    1999                  89 ; dup
    2000                  90 ; dup_x1
    2001                  91 ; dup_x2
    2002                  92 ; dup2
    2003                  95 ; swap
    2004                  96 ; iadd
    2005                  97 ; ladd
    2006                  100 ; isub
    2007                  101 ; lsub
    2008                  104 ; imul
    2009                  105 ; lmul
    2010                  116 ; ineg
    2011                  117 ; lneg
    2012                  120 ; ishl
    2013                  121 ; lshl
    2014                  122 ; ishr
    2015                  123 ; lshr
    2016                  126 ; iand
    2017                  127 ; land
    2018                  128 ; ior
    2019                  129 ; lor
    2020                  130 ; ixor
    2021                  131 ; lxor
    2022                  133 ; i2l
    2023                  136 ; l2i
    2024                  148 ; lcmp
    2025                  153 ; ifeq
    2026                  154 ; ifne
    2027                  155 ; ifge
    2028                  156 ; ifgt
    2029                  157 ; ifgt
    2030                  158 ; ifle
    2031                  159 ; if_icmpeq
    2032                  160 ; if_icmpne
    2033                  161 ; if_icmplt
    2034                  162 ; if_icmpge
    2035                  163 ; if_icmpgt
    2036                  164 ; if_icmple
    2037                  165 ; if_acmpeq
    2038                  166 ; if_acmpne
    2039                  167 ; goto
    2040                  168 ; jsr
    2041                  169 ; ret
    2042                  176 ; areturn
    2043                  177 ; return
    2044                  190 ; arraylength
    2045                  191 ; athrow
    2046                  198 ; ifnull
    2047                  202 ; label
    2048                  ))
    2049       (setf (gethash n ht) nil))))
    2050 
    2051 (initialize-resolvers)
    2052 
    2053 (defmacro define-resolver (opcodes args &body body)
    2054   (let ((name (gensym)))
    2055     (if (listp opcodes)
    2056         `(progn
    2057            (defun ,name ,args ,@body)
    2058            (eval-when (:load-toplevel :execute)
    2059              (dolist (op ',opcodes)
    2060                (setf (gethash op +resolvers+) (symbol-function ',name)))))
    2061         `(progn
    2062            (defun ,name ,args ,@body)
    2063            (eval-when (:load-toplevel :execute)
    2064              (setf (gethash ,opcodes +resolvers+) (symbol-function ',name)))))))
    2065 
    2066 ;; aload
    2067 (define-resolver 25 (instruction)
    2068  (let* ((args (instruction-args instruction))
    2069         (index (car args)))
    2070    (declare (type (unsigned-byte 16) index))
    2071    (cond ((<= 0 index 3)
    2072           (inst (+ index 42)))
    2073          ((<= 0 index 255)
    2074           (inst 25 index))
    2075          (t
    2076           (error "ALOAD unsupported case")))))
    2077 
    2078 ;; astore
    2079 (define-resolver 58 (instruction)
    2080   (let* ((args (instruction-args instruction))
    2081          (index (car args)))
    2082     (declare (type (unsigned-byte 16) index))
    2083     (cond ((<= 0 index 3)
    2084            (inst (+ index 75)))
    2085           ((<= 0 index 255)
    2086            (inst 58 index))
    2087           (t
    2088            (error "ASTORE unsupported case")))))
    2089 
    2090 ;; iload
    2091 (define-resolver 21 (instruction)
    2092   (let* ((args (instruction-args instruction))
    2093          (index (car args)))
    2094     (declare (type (unsigned-byte 16) index))
    2095     (cond ((<= 0 index 3)
    2096            (inst (+ index 26)))
    2097           ((<= 0 index 255)
    2098            (inst 21 index))
    2099           (t
    2100            (error "ILOAD unsupported case")))))
    2101 
    2102 ;; istore
    2103 (define-resolver 54 (instruction)
    2104   (let* ((args (instruction-args instruction))
    2105          (index (car args)))
    2106     (declare (type (unsigned-byte 16) index))
    2107     (cond ((<= 0 index 3)
    2108            (inst (+ index 59)))
    2109           ((<= 0 index 255)
    2110            (inst 54 index))
    2111           (t
    2112            (error "ASTORE unsupported case")))))
    2113 
    2114 ;; lload
    2115 (define-resolver 22 (instruction)
    2116   (let* ((args (instruction-args instruction))
    2117          (index (car args)))
    2118     (declare (type (unsigned-byte 16) index))
    2119     (cond ((<= 0 index 3)
    2120            (inst (+ index 30)))
    2121           ((<= 0 index 255)
    2122            (inst 22 index))
    2123           (t
    2124            (error "LLOAD unsupported case")))))
    2125 
    2126 ;; lstore
    2127 (define-resolver 55 (instruction)
    2128   (let* ((args (instruction-args instruction))
    2129          (index (car args)))
    2130     (declare (type (unsigned-byte 16) index))
    2131     (cond ((<= 0 index 3)
    2132            (inst (+ index 63)))
    2133           ((<= 0 index 255)
    2134            (inst 55 index))
    2135           (t
    2136            (error "ASTORE unsupported case")))))
    2137 
    2138 ;; getstatic, putstatic
    2139 (define-resolver (178 179) (instruction)
    2140   (let* ((args (instruction-args instruction))
    2141          (index (pool-field (first args) (second args) (third args))))
    2142     (inst (instruction-opcode instruction) (u2 index))))
    2143 
    2144 ;; bipush, sipush
    2145 (define-resolver (16 17) (instruction)
    2146   (let* ((args (instruction-args instruction))
    2147          (n (first args)))
    2148     (declare (type fixnum n))
    2149     (cond ((<= 0 n 5)
    2150            (inst (+ n 3)))
    2151           ((<= -128 n 127)
    2152            (inst 16 (logand n #xff))) ; BIPUSH
    2153           (t ; SIPUSH
    2154            (inst 17 (u2 n))))))
    2155 
    2156 ;; invokevirtual, invokespecial, invokestatic class-name method-name descriptor
    2157 (define-resolver (182 183 184) (instruction)
    2158   (let* ((args (instruction-args instruction))
    2159          (index (pool-method (first args) (second args) (third args))))
    2160     (setf (instruction-args instruction) (u2 index))
    2161     instruction))
    2162 
    2163 ;; ldc
    2164 (define-resolver 18 (instruction)
    2165   (let* ((args (instruction-args instruction)))
    2166     (unless (= (length args) 1)
    2167       (error "Wrong number of args for LDC."))
    2168     (if (> (car args) 255)
    2169         (inst 19 (u2 (car args))) ; LDC_W
    2170         (inst 18 args))))
    2171 
    2172 ;; ldc2_w
    2173 (define-resolver 20 (instruction)
    2174 ;;   (format t "resolving ldc2_w...~%")
    2175   (let* ((args (instruction-args instruction)))
    2176 ;;     (format t "args = ~S~%" args)
    2177     (unless (= (length args) 1)
    2178       (error "Wrong number of args for LDC2_W."))
    2179 ;;     (if (> (car args) 255)
    2180 ;;         (inst 19 (u2 (car args))) ; LDC_W
    2181 ;;         (inst 18 args))))
    2182     (inst 20 (u2 (car args)))))
    2183 
    2184 ;; getfield, putfield class-name field-name type-name
    2185 (define-resolver (180 181) (instruction)
    2186   (let* ((args (instruction-args instruction))
    2187          (index (pool-field (first args) (second args) (third args))))
    2188     (inst (instruction-opcode instruction) (u2 index))))
    2189 
    2190 ;; new, anewarray, checkcast, instanceof class-name
    2191 (define-resolver (187 189 192 193) (instruction)
    2192   (let* ((args (instruction-args instruction))
    2193          (index (pool-class (first args))))
    2194     (inst (instruction-opcode instruction) (u2 index))))
    2195 
    2196 ;; iinc
    2197 (define-resolver 132 (instruction)
    2198   (let* ((args (instruction-args instruction))
    2199          (register (first args))
    2200          (n (second args)))
    2201     (inst 132 (list register (logand n #xff)))))
    2202 
    2203 (defknown resolve-instruction (t) t)
    2204 (defun resolve-instruction (instruction)
    2205   (declare (optimize speed))
    2206   (let ((resolver (gethash1 (instruction-opcode instruction) +resolvers+)))
    2207     (if resolver
    2208         (funcall resolver instruction)
    2209         instruction)))
    2210 
    2211 (defun resolve-instructions (code)
    2212   (let ((vector (make-array 512 :fill-pointer 0 :adjustable t)))
    2213     (dotimes (index (length code) vector)
    2214       (declare (type (unsigned-byte 16) index))
    2215       (let ((instruction (svref code index)))
    2216         (case (instruction-opcode instruction)
    2217           (205 ; CLEAR-VALUES
    2218            (let ((instructions
    2219                   (list
    2220                    (inst 'aload *thread*)
    2221                    (inst 'aconst_null)
    2222                    (inst 'putfield (list +lisp-thread-class+ "_values"
    2223                                          "[Lorg/armedbear/lisp/LispObject;")))))
    2224              (dolist (instruction instructions)
    2225                (vector-push-extend (resolve-instruction instruction) vector))))
    2226           (t
    2227            (vector-push-extend (resolve-instruction instruction) vector)))))))
    2228 
    2229 ;; (defconstant +branch-opcodes+
    2230 ;;   '(153 ; IFEQ
    2231 ;;     154 ; IFNE
    2232 ;;     155 ; IFLT
    2233 ;;     156 ; IFGE
    2234 ;;     157 ; IFGT
    2235 ;;     158 ; IFLE
    2236 ;;     159 ; IF_ICMPEQ
    2237 ;;     160 ; IF_ICMPNE
    2238 ;;     161 ; IF_ICMPLT
    2239 ;;     162 ; IF_ICMPGE
    2240 ;;     163 ; IF_ICMPGT
    2241 ;;     164 ; IF_ICMPLE
    2242 ;;     165 ; IF_ACMPEQ
    2243 ;;     166 ; IF_ACMPNE
    2244 ;;     167 ; GOTO
    2245 ;;     168 ; JSR
    2246 ;;     198 ; IFNULL
    2247 ;;     ))
    2248 
    2249 (declaim (ftype (function (t) t) branch-opcode-p))
    2250 (declaim (inline branch-opcode-p))
    2251 (defun branch-opcode-p (opcode)
    2252   (declare (optimize speed))
    2253   (declare (type '(integer 0 255) opcode))
    2254   (or (<= 153 opcode 168)
    2255       (= opcode 198)))
    2256 
    2257 (declaim (ftype (function (t t t) t) walk-code))
    2258 (defun walk-code (code start-index depth)
    2259   (declare (optimize speed))
    2260   (declare (type fixnum start-index depth))
    2261   (do* ((i start-index (1+ i))
    2262         (limit (length code)))
    2263        ((>= i limit))
    2264     (declare (type fixnum i limit))
    2265     (let* ((instruction (aref code i))
    2266            (instruction-depth (instruction-depth instruction))
    2267            (instruction-stack (instruction-stack instruction)))
    2268       (declare (type fixnum instruction-stack))
    2269       (when instruction-depth
    2270         (unless (= (the fixnum instruction-depth) (the fixnum (+ depth instruction-stack)))
    2271           (format t "~&Stack inconsistency at index ~D: found ~S, expected ~S.~%"
    2272                    i instruction-depth (+ depth instruction-stack)))
    2273         (return-from walk-code))
    2274       (let ((opcode (instruction-opcode instruction)))
    2275         (unless (eql opcode 168) ; JSR
    2276           (setf depth (+ depth instruction-stack)))
    2277         (setf (instruction-depth instruction) depth)
    2278         (if (eql opcode 168) ; JSR
    2279             (let ((label (car (instruction-args instruction))))
    2280               (declare (type symbol label))
    2281               (walk-code code (symbol-value label) (1+ depth)))
    2282             (when (branch-opcode-p opcode)
    2283               (let ((label (car (instruction-args instruction))))
    2284                 (declare (type symbol label))
    2285                 (walk-code code (symbol-value label) depth))))
    2286         (when (member opcode '(167 169 176 191)) ; GOTO RET ARETURN ATHROW
    2287           ;; Current path ends.
    2288           (return-from walk-code))))))
    2289 
    2290 (declaim (ftype (function () t) analyze-stack))
    2291 (defun analyze-stack ()
    2292   (declare (optimize speed))
    2293   (let* ((code *code*)
    2294          (code-length (length code)))
    2295     (declare (type vector code))
    2296     (dotimes (i code-length)
    2297       (declare (type (unsigned-byte 16) i))
    2298       (let* ((instruction (aref code i))
    2299              (opcode (instruction-opcode instruction)))
    2300         (when (eql opcode 202) ; LABEL
    2301           (let ((label (car (instruction-args instruction))))
    2302             (set label i)))
    2303         (if (instruction-stack instruction)
    2304             (when (opcode-stack-effect opcode)
    2305               (unless (eql (instruction-stack instruction) (opcode-stack-effect opcode))
    2306                 (sys::%format t "instruction-stack = ~S opcode-stack-effect = ~S~%"
    2307                          (instruction-stack instruction)
    2308                          (opcode-stack-effect opcode))
    2309                 (sys::%format t "index = ~D instruction = ~A~%" i (print-instruction instruction))))
    2310             (setf (instruction-stack instruction) (opcode-stack-effect opcode)))
    2311         (unless (instruction-stack instruction)
    2312           (sys::%format t "no stack information for instruction ~D~%" (instruction-opcode instruction))
    2313           (aver nil))))
    2314     (walk-code code 0 0)
    2315     (dolist (handler *handlers*)
    2316       ;; Stack depth is always 1 when handler is called.
    2317       (walk-code code (symbol-value (handler-code handler)) 1))
    2318     (let ((max-stack 0))
    2319       (declare (type fixnum max-stack))
    2320       (dotimes (i code-length)
    2321         (declare (type (unsigned-byte 16) i))
    2322         (let* ((instruction (aref code i))
    2323                (instruction-depth (instruction-depth instruction)))
    2324           (when instruction-depth
    2325             (setf max-stack (max max-stack (the fixnum instruction-depth))))))
    2326 ;;       (when *compiler-debug*
    2327 ;;         (sys::%format t "compiland name = ~S~%" (compiland-name *current-compiland*))
    2328 ;;         (sys::%format t "max-stack = ~D~%" max-stack)
    2329 ;;         (sys::%format t "----- after stack analysis -----~%")
    2330 ;;         (print-code))
    2331       max-stack)))
    2332 
    2333 (defun resolve-variables ()
    2334   (let ((code (nreverse *code*)))
    2335     (setf *code* nil)
    2336     (dolist (instruction code)
    2337       (case (instruction-opcode instruction)
    2338         (206 ; VAR-REF
    2339          ;; obsolete
    2340          (aver nil))
    2341         (207 ; VAR-SET
    2342          (let ((variable (car (instruction-args instruction))))
    2343            (aver (variable-p variable))
    2344            (aver (not (variable-special-p variable)))
    2345            (cond ((variable-register variable)
    2346                   (dformat t "register = ~S~%" (variable-register variable))
    2347                   (emit 'astore (variable-register variable)))
    2348                  ((variable-closure-index variable)
    2349                   (dformat t "closure-index = ~S~%" (variable-closure-index variable))
    2350                   (aver (not (null (compiland-closure-register *current-compiland*))))
    2351                   (emit 'aload (compiland-closure-register *current-compiland*))
    2352                   (emit 'swap) ; array value
    2353                   (emit 'bipush (variable-closure-index variable))
    2354                   (emit 'swap) ; array index value
    2355                   (emit 'aastore))
    2356                  (t
    2357                   (dformat t "var-set fall-through case~%")
    2358                   (aver (not (null (compiland-argument-register *current-compiland*))))
    2359                   (emit 'aload (compiland-argument-register *current-compiland*)) ; Stack: value array
    2360                   (emit 'swap) ; array value
    2361                   (emit 'bipush (variable-index variable)) ; array value index
    2362                   (emit 'swap) ; array index value
    2363                   (emit 'aastore)))))
    2364         (t
    2365          (push instruction *code*))))))
    2366 
    2367 (defun finalize-code ()
    2368   (setf *code* (nreverse (coerce *code* 'vector))))
    2369 
    2370 (defun print-code ()
    2371   (dotimes (i (length *code*))
    2372     (let ((instruction (elt *code* i)))
    2373       (sys::%format t "~D ~A ~S ~S ~S~%"
    2374                     i
    2375                     (opcode-name (instruction-opcode instruction))
    2376                     (instruction-args instruction)
    2377                     (instruction-stack instruction)
    2378                     (instruction-depth instruction)))))
    2379 
    2380 (defun print-code2 (code)
    2381   (dotimes (i (length code))
    2382     (let ((instruction (elt code i)))
    2383       (case (instruction-opcode instruction)
    2384         (202 ; LABEL
    2385          (format t "~A:~%" (car (instruction-args instruction))))
    2386         (t
    2387          (format t "~8D:   ~A ~S~%"
    2388                  i
    2389                  (opcode-name (instruction-opcode instruction))
    2390                  (instruction-args instruction)))))))
    2391 
    2392 (declaim (ftype (function (t) boolean) label-p))
    2393 (defun label-p (instruction)
    2394 ;;   (declare (optimize safety))
    2395 ;;   (declare (type instruction instruction))
    2396   (and instruction
    2397        (= (the fixnum (instruction-opcode (the instruction instruction))) 202)))
    2398 
    2399 (declaim (ftype (function (t) t) instruction-label))
    2400 (defun instruction-label (instruction)
    2401 ;;   (declare (optimize safety))
    2402   (and instruction
    2403        (= (instruction-opcode (the instruction instruction)) 202)
    2404        (car (instruction-args instruction))))
    2405 
    2406 ;; Remove unused labels.
    2407 (defun optimize-1 ()
    2408   (let ((code (coerce *code* 'vector))
    2409         (changed nil)
    2410         (marker (gensym)))
    2411     ;; Mark the labels that are actually branched to.
    2412     (dotimes (i (length code))
    2413       (declare (type (unsigned-byte 16) i))
    2414       (let ((instruction (aref code i)))
    2415         (when (branch-opcode-p (instruction-opcode instruction))
    2416           (let ((label (car (instruction-args instruction))))
    2417             (set label marker)))))
    2418     ;; Add labels used for exception handlers.
    2419     (dolist (handler *handlers*)
    2420       (set (handler-from handler) marker)
    2421       (set (handler-to handler) marker)
    2422       (set (handler-code handler) marker))
    2423     ;; Remove labels that are not used as branch targets.
    2424     (dotimes (i (length code))
    2425       (declare (type (unsigned-byte 16) i))
    2426       (let ((instruction (aref code i)))
    2427         (when (= (instruction-opcode instruction) 202) ; LABEL
    2428           (let ((label (car (instruction-args instruction))))
    2429             (declare (type symbol label))
    2430             (unless (eq (symbol-value label) marker)
    2431               (setf (aref code i) nil)
    2432               (setf changed t))))))
    2433     (when changed
    2434       (setf *code* (delete nil code))
    2435       t)))
    2436 
    2437 (defun optimize-2 ()
    2438   (let* ((code (coerce *code* 'vector))
    2439          (length (length code))
    2440          (changed nil))
    2441     (declare (type (unsigned-byte 16) length))
    2442     ;; Since we're looking at this instruction and the next one, we can stop
    2443     ;; one before the end.
    2444     (dotimes (i (1- length))
    2445       (declare (type (unsigned-byte 16) i))
    2446       (let ((instruction (aref code i)))
    2447         (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO
    2448           (do* ((j (1+ i) (1+ j))
    2449                 (next-instruction (aref code j) (aref code j)))
    2450                ((>= j length))
    2451             (declare (type (unsigned-byte 16) j))
    2452             (when next-instruction
    2453               (cond ((= (instruction-opcode next-instruction) 167) ; GOTO
    2454                      (cond ((= j (1+ i))
    2455                             ;; Two GOTOs in a row: the second instruction is
    2456                             ;; unreachable.
    2457                             (setf (aref code j) nil)
    2458                             (setf changed t))
    2459                            (;;(equal next-instruction instruction)
    2460                             (eq (car (instruction-args next-instruction))
    2461                                 (car (instruction-args instruction)))
    2462                             ;; We've reached another GOTO to the same destination.
    2463                             ;; We don't need the first GOTO; we can just fall
    2464                             ;; through to the second one.
    2465                             (setf (aref code i) nil)
    2466                             (setf changed t)))
    2467                      (return))
    2468                     ((= (instruction-opcode next-instruction) 202) ; LABEL
    2469                      (when (eq (car (instruction-args instruction))
    2470                                (car (instruction-args next-instruction)))
    2471                        ;; GOTO next instruction; we don't need this one.
    2472                        (setf (aref code i) nil)
    2473                        (setf changed t)
    2474                        (return)))
    2475                     (t
    2476                      ;; Not a GOTO or a label.
    2477                      (return))))))))
    2478     (when changed
    2479       (setf *code* (delete nil code))
    2480       t)))
    2481 
    2482 (declaim (ftype (function (t) hash-table) hash-labels))
    2483 (defun hash-labels (code)
    2484   (let ((ht (make-hash-table :test 'eq))
    2485         (code (coerce code 'vector))
    2486         (pending-labels '()))
    2487     (dotimes (i (length code))
    2488       (declare (type (unsigned-byte 16) i))
    2489       (let ((instruction (aref code i)))
    2490         (cond ((label-p instruction)
    2491                (push (instruction-label instruction) pending-labels))
    2492               (t
    2493                ;; Not a label.
    2494                (when pending-labels
    2495                  (dolist (label pending-labels)
    2496                    (setf (gethash label ht) instruction))
    2497                  (setf pending-labels nil))))))
    2498     ht))
    2499 
    2500 (defun optimize-2b ()
    2501   (let* ((code (coerce *code* 'vector))
    2502          (ht (hash-labels code))
    2503          (changed nil))
    2504     (dotimes (i (length code))
    2505       (declare (type (unsigned-byte 16) i))
    2506       (let ((instruction (aref code i)))
    2507         (when (and instruction (= (instruction-opcode instruction) 167)) ; GOTO
    2508           (let* ((target-label (car (instruction-args instruction)))
    2509                  (next-instruction (gethash1 target-label ht)))
    2510             (when next-instruction
    2511               (case (instruction-opcode next-instruction)
    2512                 (167 ; GOTO
    2513                  (setf (instruction-args instruction)
    2514                        (instruction-args next-instruction)
    2515                        changed t))
    2516                 (176 ; ARETURN
    2517                  (setf (instruction-opcode instruction) 176
    2518                        (instruction-args instruction) nil
    2519                        changed t))))))))
    2520     (when changed
    2521       (setf *code* code)
    2522       t)))
    2523 
    2524 ;; CLEAR-VALUES CLEAR-VALUES => CLEAR-VALUES
    2525 ;; GETSTATIC POP => nothing
    2526 (defun optimize-3 ()
    2527   (let* ((code (coerce *code* 'vector))
    2528          (changed nil))
    2529     (dotimes (i (1- (length code)))
    2530       (declare (type (unsigned-byte 16) i))
    2531       (let* ((this-instruction (aref code i))
    2532              (this-opcode (and this-instruction (instruction-opcode this-instruction)))
    2533              (next-instruction (aref code (1+ i)))
    2534              (next-opcode (and next-instruction (instruction-opcode next-instruction))))
    2535         (case this-opcode
    2536           (205 ; CLEAR-VALUES
    2537            (when (eql next-opcode 205) ; CLEAR-VALUES
    2538              (setf (aref code i) nil)
    2539              (setf changed t)))
    2540           (178 ; GETSTATIC
    2541            (when (eql next-opcode 87) ; POP
    2542              (setf (aref code i) nil)
    2543              (setf (aref code (1+ i)) nil)
    2544              (setf changed t))))))
    2545     (when changed
    2546       (setf *code* (delete nil code))
    2547       t)))
    2548 
    2549 (defun delete-unreachable-code ()
    2550   ;; Look for unreachable code after GOTO.
    2551   (let* ((code (coerce *code* 'vector))
    2552          (changed nil)
    2553          (after-goto/areturn nil))
    2554     (dotimes (i (length code))
    2555       (declare (type (unsigned-byte 16) i))
    2556       (let* ((instruction (aref code i))
    2557              (opcode (instruction-opcode instruction)))
    2558         (cond (after-goto/areturn
    2559                (if (= opcode 202) ; LABEL
    2560                    (setf after-goto/areturn nil)
    2561                    ;; Unreachable.
    2562                    (progn
    2563                      (setf (aref code i) nil)
    2564                      (setf changed t))))
    2565               ((= opcode 176) ; ARETURN
    2566                (setf after-goto/areturn t))
    2567               ((= opcode 167) ; GOTO
    2568                (setf after-goto/areturn t)))))
    2569     (when changed
    2570       (setf *code* (delete nil code))
    2571       t)))
    2572 
    2573 (defvar *enable-optimization* t)
    2574 
    2575 (defknown optimize-code () t)
    2576 (defun optimize-code ()
    2577   (unless *enable-optimization*
    2578     (format t "optimizations are disabled~%"))
    2579   (when *enable-optimization*
    2580     (when *compiler-debug*
    2581       (format t "----- before optimization -----~%")
    2582       (print-code))
    2583     (loop
    2584       (let ((changed-p nil))
    2585         (setf changed-p (or (optimize-1) changed-p))
    2586         (setf changed-p (or (optimize-2) changed-p))
    2587         (setf changed-p (or (optimize-2b) changed-p))
    2588         (setf changed-p (or (optimize-3) changed-p))
    2589         (setf changed-p (or (delete-unreachable-code) changed-p))
    2590         (unless changed-p
    2591           (return))))
    2592     (unless (vectorp *code*)
    2593       (setf *code* (coerce *code* 'vector)))
    2594     (when *compiler-debug*
    2595       (sys::%format t "----- after optimization -----~%")
    2596       (print-code)))
    2597   t)
    2598 
    2599 (defun code-bytes (code)
    2600   (let ((length 0))
    2601     (declare (type (unsigned-byte 16) length))
    2602     ;; Pass 1: calculate label offsets and overall length.
    2603     (dotimes (i (length code))
    2604       (declare (type (unsigned-byte 16) i))
    2605       (let* ((instruction (aref code i))
    2606              (opcode (instruction-opcode instruction)))
    2607         (if (= opcode 202) ; LABEL
    2608             (let ((label (car (instruction-args instruction))))
    2609               (set label length))
    2610             (incf length (opcode-size opcode)))))
    2611     ;; Pass 2: replace labels with calculated offsets.
    2612     (let ((index 0))
    2613       (declare (type (unsigned-byte 16) index))
    2614       (dotimes (i (length code))
    2615         (declare (type (unsigned-byte 16) i))
    2616         (let ((instruction (aref code i)))
    2617           (when (branch-opcode-p (instruction-opcode instruction))
    2618             (let* ((label (car (instruction-args instruction)))
    2619                    (offset (- (the (unsigned-byte 16) (symbol-value (the symbol label))) index)))
    2620               (setf (instruction-args instruction) (u2 offset))))
    2621           (unless (= (instruction-opcode instruction) 202) ; LABEL
    2622             (incf index (opcode-size (instruction-opcode instruction)))))))
    2623     ;; Expand instructions into bytes, skipping LABEL pseudo-instructions.
    2624     (let ((bytes (make-array length))
    2625           (index 0))
    2626       (declare (type (unsigned-byte 16) index))
    2627       (dotimes (i (length code))
    2628         (declare (type (unsigned-byte 16) i))
    2629         (let ((instruction (aref code i)))
    2630           (unless (= (instruction-opcode instruction) 202) ; LABEL
    2631             (setf (svref bytes index) (instruction-opcode instruction))
    2632             (incf index)
    2633             (dolist (byte (instruction-args instruction))
    2634               (setf (svref bytes index) byte)
    2635               (incf index)))))
    2636       bytes)))
    2637 
    2638 (declaim (inline write-u1))
    2639 (defun write-u1 (n stream)
    2640   (declare (optimize speed))
    2641   (declare (type (unsigned-byte 8) n))
    2642   (declare (type stream stream))
    2643   (write-8-bits n stream))
    2644 
    2645 (defknown write-u2 (t t) t)
    2646 (defun write-u2 (n stream)
    2647   (declare (optimize speed))
    2648   (declare (type (unsigned-byte 16) n))
    2649   (declare (type stream stream))
    2650   (write-8-bits (ash n -8) stream)
    2651   (write-8-bits (logand n #xFF) stream))
    2652 
    2653 (defknown write-u4 (integer stream) t)
    2654 (defun write-u4 (n stream)
    2655   (declare (optimize speed))
    2656   (declare (type (unsigned-byte 32) n))
    2657   (write-u2 (ash n -16) stream)
    2658   (write-u2 (logand n #xFFFF) stream))
    2659 
    2660 (declaim (ftype (function (t t) t) write-s4))
    2661 (defun write-s4 (n stream)
    2662   (declare (optimize speed))
    2663   (cond ((minusp n)
    2664          (write-u4 (1+ (logxor (- n) #xFFFFFFFF)) stream))
    2665         (t
    2666          (write-u4 n stream))))
    2667 
    2668 (declaim (ftype (function (t t t) t) write-ascii))
    2669 (defun write-ascii (string length stream)
    2670   (declare (type string string))
    2671   (declare (type (unsigned-byte 16) length))
    2672   (declare (type stream stream))
    2673   (write-u2 length stream)
    2674   (dotimes (i length)
    2675     (declare (type (unsigned-byte 16) i))
    2676     (write-8-bits (char-code (char string i)) stream)))
    2677 
    2678 (declaim (ftype (function (t t) t) write-utf8))
    2679 (defun write-utf8 (string stream)
    2680   (declare (optimize speed))
    2681   (declare (type string string))
    2682   (declare (type stream stream))
    2683   (let ((length (length string))
    2684         (must-convert nil))
    2685     (declare (type fixnum length))
    2686     (dotimes (i length)
    2687       (declare (type fixnum i))
    2688       (unless (< 0 (char-code (char string i)) #x80)
    2689         (setf must-convert t)
    2690         (return)))
    2691     (if must-convert
    2692         (let ((octets (make-array (* length 2)
    2693                                   :element-type '(unsigned-byte 8)
    2694                                   :adjustable t
    2695                                   :fill-pointer 0)))
    2696           (declare (type (vector (unsigned-byte 8)) octets))
    2697           (dotimes (i length)
    2698             (declare (type fixnum i))
    2699             (let* ((c (char string i))
    2700                    (n (char-code c)))
    2701               (cond ((zerop n)
    2702                      (vector-push-extend #xC0 octets)
    2703                      (vector-push-extend #x80 octets))
    2704                     ((< 0 n #x80)
    2705                      (vector-push-extend n octets))
    2706                     (t
    2707                      (let ((char-octets (char-to-utf8 c)))
    2708                        (dotimes (j (length char-octets))
    2709                          (declare (type fixnum j))
    2710                          (vector-push-extend (svref char-octets j) octets)))))))
    2711           (write-u2 (length octets) stream)
    2712           (dotimes (i (length octets))
    2713             (declare (type fixnum i))
    2714             (write-8-bits (aref octets i) stream)))
    2715         (write-ascii string length stream))))
    2716 
    2717 (defknown write-constant-pool-entry (t t) t)
    2718 (defun write-constant-pool-entry (entry stream)
    2719   (declare (optimize speed))
    2720   (declare (type stream stream))
    2721   (let ((tag (first entry)))
    2722     (declare (type (integer 1 12) tag))
    2723     (write-u1 tag stream)
    2724     (case tag
    2725       (1 ; UTF8
    2726        (write-utf8 (third entry) stream))
    2727       (3 ; int
    2728        (write-s4 (second entry) stream))
    2729       ((5 6)
    2730        (write-u4 (second entry) stream)
    2731        (write-u4 (third entry) stream))
    2732       ((9 10 11 12)
    2733        (write-u2 (second entry) stream)
    2734        (write-u2 (third entry) stream))
    2735       ((7 8)
    2736        (write-u2 (second entry) stream))
    2737       (t
    2738        (error "write-constant-pool-entry unhandled tag ~D~%" tag)))))
    2739 
    2740 (defun write-constant-pool (stream)
    2741   (declare (optimize speed))
    2742   (write-u2 *pool-count* stream)
    2743   (dolist (entry (reverse *pool*))
    2744     (write-constant-pool-entry entry stream)))
    2745 
    2746 (defstruct (field (:constructor make-field (name descriptor)))
    2747   access-flags
    2748   name
    2749   descriptor
    2750   name-index
    2751   descriptor-index)
    2752 
    2753 (defstruct (java-method (:conc-name method-) (:constructor make-method))
    2754   access-flags
    2755   name
    2756   descriptor
    2757   name-index
    2758   descriptor-index
    2759   max-stack
    2760   max-locals
    2761   code
    2762   handlers)
    2763 
    2764 (defun emit-constructor-lambda-name (lambda-name)
    2765   (cond ((and lambda-name (symbolp lambda-name) (symbol-package (truly-the symbol lambda-name)))
    2766          (emit 'ldc (pool-string (symbol-name (truly-the symbol lambda-name))))
    2767          (emit 'ldc (pool-string (package-name (symbol-package (truly-the symbol lambda-name)))))
    2768          (emit-invokestatic +lisp-class+ "internInPackage"
    2769                             (list +java-string+ +java-string+) +lisp-symbol+))
    2770         (t
    2771          ;; No name.
    2772          (emit-push-nil))))
    2773 
    2774 (defun emit-constructor-lambda-list (lambda-list)
    2775   (if lambda-list
    2776       (let* ((*print-level* nil)
    2777              (*print-length* nil)
    2778              (s (sys::%format nil "~S" lambda-list)))
    2779         (emit 'ldc (pool-string s))
    2780         (emit-invokestatic +lisp-class+ "readObjectFromString"
    2781                            (list +java-string+) +lisp-object+))
    2782       (emit-push-nil)))
    2783 
    2784 (defun make-constructor (super lambda-name args)
    2785   (let* ((*compiler-debug* nil) ; We don't normally need to see debugging output for constructors.
    2786          (constructor (make-method :name "<init>"
    2787                                    :descriptor "()V"))
    2788          (*code* ())
    2789          (*handlers* nil))
    2790     (setf (method-name-index constructor) (pool-name (method-name constructor)))
    2791     (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor)))
    2792     (setf (method-max-locals constructor) 1)
    2793     (emit 'aload_0) ;; this
    2794     (cond ((equal super +lisp-compiled-function-class+)
    2795            (emit-constructor-lambda-name lambda-name)
    2796            (emit-constructor-lambda-list args)
    2797            (emit-push-nil) ;; body
    2798            (emit 'aconst_null) ;; environment
    2799            (emit-invokespecial-init super
    2800                                     (list +lisp-object+ +lisp-object+
    2801                                           +lisp-object+ +lisp-environment+)))
    2802           ((equal super +lisp-primitive-class+)
    2803            (emit-constructor-lambda-name lambda-name)
    2804            (emit-constructor-lambda-list args)
    2805            (emit-invokespecial-init super (lisp-object-arg-types 2)))
    2806           ((equal super "org/armedbear/lisp/Primitive0R")
    2807            (emit-constructor-lambda-name lambda-name)
    2808            (push '&REST args)
    2809            (emit-constructor-lambda-list args)
    2810            (emit-invokespecial-init super (lisp-object-arg-types 2)))
    2811           ((equal super "org/armedbear/lisp/Primitive1R")
    2812            (emit-constructor-lambda-name lambda-name)
    2813            (setf args (list (first args) '&REST (second args)))
    2814            (emit-constructor-lambda-list args)
    2815            (emit-invokespecial-init super (lisp-object-arg-types 2)))
    2816           ((equal super "org/armedbear/lisp/Primitive2R")
    2817            (emit-constructor-lambda-name lambda-name)
    2818            (setf args (list (first args) (second args) '&REST (third args)))
    2819            (emit-constructor-lambda-list args)
    2820            (emit-invokespecial-init super (lisp-object-arg-types 2)))
    2821           ((equal super +lisp-ctf-class+)
    2822            (emit-constructor-lambda-list args)
    2823            (emit-invokespecial-init super (lisp-object-arg-types 1)))
    2824           (t
    2825            (aver nil)))
    2826     (setf *code* (append *static-code* *code*))
    2827     (emit 'return)
    2828     (finalize-code)
    2829     ;;(optimize-code)
    2830     (setf *code* (resolve-instructions *code*))
    2831     (setf (method-max-stack constructor) (analyze-stack))
    2832     (setf (method-code constructor) (code-bytes *code*))
    2833     (setf (method-handlers constructor) (nreverse *handlers*))
    2834     constructor))
    2835 
    2836 (defun write-exception-table (method stream)
    2837   (let ((handlers (method-handlers method)))
    2838     (write-u2 (length handlers) stream) ; number of entries
    2839     (dolist (handler handlers)
    2840       (write-u2 (symbol-value (handler-from handler)) stream)
    2841       (write-u2 (symbol-value (handler-to handler)) stream)
    2842       (write-u2 (symbol-value (handler-code handler)) stream)
    2843       (write-u2 (handler-catch-type handler) stream))))
    2844 
    2845 (defun write-source-file-attr (source-file stream)
    2846   (let* ((name-index (pool-name "SourceFile"))
    2847          (source-file-index (pool-name source-file)))
    2848     (write-u2 name-index stream)
    2849     ;; "The value of the attribute_length item of a SourceFile_attribute
    2850     ;; structure must be 2."
    2851     (write-u4 2 stream)
    2852     (write-u2 source-file-index stream)))
    2853 
    2854 (defvar *source-line-number* nil)
    2855 
    2856 (defun write-line-number-table (stream)
    2857   (let* ((name-index (pool-name "LineNumberTable")))
    2858     (write-u2 name-index stream)
    2859     (write-u4 6 stream) ; "the length of the attribute, excluding the initial six bytes"
    2860     (write-u2 1 stream) ; number of entries
    2861     (write-u2 0 stream) ; start_pc
    2862     (write-u2 *source-line-number* stream)))
    2863 
    2864 (defun write-code-attr (method stream)
    2865   (declare (optimize speed))
    2866   (declare (type stream stream))
    2867   (let* ((name-index (pool-name "Code"))
    2868          (code (method-code method))
    2869          (code-length (length code))
    2870          (line-number-available-p (and (fixnump *source-line-number*)
    2871                                        (plusp *source-line-number*)))
    2872          (length (+ code-length 12
    2873                     (* (length (method-handlers method)) 8)
    2874                     (if line-number-available-p 12 0)))
    2875          (max-stack (or (method-max-stack method) 20))
    2876          (max-locals (or (method-max-locals method) 1)))
    2877     (write-u2 name-index stream)
    2878     (write-u4 length stream)
    2879     (write-u2 max-stack stream)
    2880     (write-u2 max-locals stream)
    2881     (write-u4 code-length stream)
    2882     (dotimes (i code-length)
    2883       (declare (type index i))
    2884       (write-u1 (the (unsigned-byte 8) (svref code i)) stream))
    2885     (write-exception-table method stream)
    2886     (cond (line-number-available-p
    2887            ; attributes count
    2888            (write-u2 1 stream)
    2889            (write-line-number-table stream))
    2890           (t
    2891            ; attributes count
    2892            (write-u2 0 stream)))))
    2893 
    2894 (defun write-method (method stream)
    2895   (declare (optimize speed))
    2896   (write-u2 (or (method-access-flags method) #x1) stream) ; access flags
    2897   (write-u2 (method-name-index method) stream)
    2898   (write-u2 (method-descriptor-index method) stream)
    2899   (write-u2 1 stream) ; attributes count
    2900   (write-code-attr method stream))
    2901 
    2902 (defun write-field (field stream)
    2903   (declare (optimize speed))
    2904   (write-u2 (or (field-access-flags field) #x1) stream) ; access flags
    2905   (write-u2 (field-name-index field) stream)
    2906   (write-u2 (field-descriptor-index field) stream)
    2907   (write-u2 0 stream)) ; attributes count
    2908 
    2909 (defknown declare-field (t t) t)
    2910 (defun declare-field (name descriptor)
    2911   (let ((field (make-field name descriptor)))
    2912     (setf (field-access-flags field) (logior #x8 #x2)) ; private static
    2913     (setf (field-name-index field) (pool-name (field-name field)))
    2914     (setf (field-descriptor-index field) (pool-name (field-descriptor field)))
    2915     (push field *fields*)))
    2916 
    2917 (defknown sanitize (symbol) string)
    2918 (defun sanitize (symbol)
    2919   (declare (type symbol symbol))
    2920   (declare (optimize speed))
    2921   (let* ((input (symbol-name symbol))
    2922          (output (make-array (length input) :fill-pointer 0 :element-type 'character)))
    2923     (dotimes (i (length input))
    2924       (declare (type fixnum i))
    2925       (let ((c (char-upcase (char input i))))
    2926         (cond ((<= #.(char-code #\A) (char-code c) #.(char-code #\Z))
    2927                (vector-push c output))
    2928               ((<= #.(char-code #\0) (char-code c) #.(char-code #\9))
    2929                (vector-push c output))
    2930               ((eql c #\-)
    2931                (vector-push #\_ output)))))
    2932     (when (plusp (length output))
    2933       output)))
    2934 
    2935 (defknown declare-symbol (symbol) string)
    2936 (defun declare-symbol (symbol)
    2937   (declare (type symbol symbol))
    2938   (let* ((ht *declared-symbols*)
    2939          (g (gethash1 symbol ht)))
    2940     (declare (type hash-table ht))
    2941     (unless g
    2942       (cond ((null (symbol-package symbol))
    2943              (setf g (if *compile-file-truename*
    2944                          (declare-object-as-string symbol)
    2945                          (declare-object symbol))))
    2946             (t
    2947              (let ((*code* *static-code*)
    2948                    (s (sanitize symbol)))
    2949                (setf g (symbol-name (gensym)))
    2950                (when s
    2951                  (setf g (concatenate 'string g "_" s)))
    2952                (declare-field g +lisp-symbol+)
    2953                (emit 'ldc (pool-string (symbol-name symbol)))
    2954                (emit 'ldc (pool-string (package-name (symbol-package symbol))))
    2955                (emit-invokestatic +lisp-class+ "internInPackage"
    2956                                   (list +java-string+ +java-string+) +lisp-symbol+)
    2957                (emit 'putstatic *this-class* g +lisp-symbol+)
    2958                (setf *static-code* *code*)
    2959                (setf (gethash symbol ht) g)))))
    2960     g))
    2961 
    2962 (defknown declare-keyword (symbol) string)
    2963 (defun declare-keyword (symbol)
    2964   (declare (type symbol symbol))
    2965   (let* ((ht *declared-symbols*)
    2966          (g (gethash1 symbol ht)))
    2967     (declare (type hash-table ht))
    2968     (unless g
    2969       (let ((*code* *static-code*))
    2970         (setf g (symbol-name (gensym)))
    2971         (declare-field g +lisp-symbol+)
    2972         (emit 'ldc (pool-string (symbol-name symbol)))
    2973         (emit-invokestatic +lisp-class+ "internKeyword"
    2974                            (list +java-string+) +lisp-symbol+)
    2975         (emit 'putstatic *this-class* g +lisp-symbol+)
    2976         (setf *static-code* *code*)
    2977         (setf (gethash symbol ht) g)))
    2978     g))
    2979 
    2980 (defknown declare-function (symbol) string)
    2981 (defun declare-function (symbol)
    2982   (declare (type symbol symbol))
    2983   (let* ((ht *declared-functions*)
    2984          (f (gethash1 symbol ht)))
    2985     (declare (type hash-table ht))
    2986     (unless f
    2987       (setf f (symbol-name (gensym)))
    2988       (let ((s (sanitize symbol)))
    2989         (when s
    2990           (setf f (concatenate 'string f "_" s))))
    2991       (let ((*code* *static-code*)
    2992             (g (gethash1 symbol (the hash-table *declared-symbols*))))
    2993         (cond (g
    2994                (emit 'getstatic *this-class* g +lisp-symbol+))
    2995               (t
    2996                (emit 'ldc (pool-string (symbol-name symbol)))
    2997                (emit 'ldc (pool-string (package-name (symbol-package symbol))))
    2998                (emit-invokestatic +lisp-class+ "internInPackage"
    2999                                   (list +java-string+ +java-string+)
    3000                                   +lisp-symbol+)))
    3001         (declare-field f +lisp-object+)
    3002         (emit-invokevirtual +lisp-symbol-class+ "getSymbolFunctionOrDie"
    3003                             nil +lisp-object+)
    3004         (emit 'putstatic *this-class* f +lisp-object+)
    3005         (setf *static-code* *code*)
    3006         (setf (gethash symbol ht) f)))
    3007     f))
    3008 
    3009 (defknown declare-setf-function (name) string)
    3010 (defun declare-setf-function (name)
    3011   (let* ((ht *declared-functions*)
    3012          (f (gethash1 name ht)))
    3013     (declare (type hash-table ht))
    3014     (unless f
    3015       (let ((symbol (cadr name)))
    3016         (declare (type symbol symbol))
    3017         (setf f (symbol-name (gensym)))
    3018         (let ((s (sanitize symbol)))
    3019           (when s
    3020             (setf f (concatenate 'string f "_SETF_" s))))
    3021         (let ((*code* *static-code*)
    3022               (g (gethash1 symbol (the hash-table *declared-symbols*))))
    3023           (cond (g
    3024                  (emit 'getstatic *this-class* g +lisp-symbol+))
    3025                 (t
    3026                  (emit 'ldc (pool-string (symbol-name symbol)))
    3027                  (emit 'ldc (pool-string (package-name (symbol-package symbol))))
    3028                  (emit-invokestatic +lisp-class+ "internInPackage"
    3029                                     (list +java-string+ +java-string+)
    3030                                     +lisp-symbol+)))
    3031           (declare-field f +lisp-object+)
    3032           (emit-invokevirtual +lisp-symbol-class+ "getSymbolSetfFunctionOrDie"
    3033                               nil +lisp-object+)
    3034           (emit 'putstatic *this-class* f +lisp-object+)
    3035           (setf *static-code* *code*)
    3036           (setf (gethash name ht) f))))
    3037     f))
    3038 
    3039 (defknown declare-local-function (local-function) string)
    3040 (defun declare-local-function (local-function)
    3041   (let* ((ht *declared-functions*)
    3042          (g (gethash1 local-function ht)))
    3043     (declare (type hash-table ht))
    3044     (unless g
    3045       (setf g (symbol-name (gensym)))
    3046       (let* ((pathname (class-file-pathname (local-function-class-file local-function)))
    3047              (*code* *static-code*))
    3048         (declare-field g +lisp-object+)
    3049         (emit 'ldc (pool-string (file-namestring pathname)))
    3050         (emit-invokestatic +lisp-class+ "loadCompiledFunction"
    3051                            (list +java-string+) +lisp-object+)
    3052         (emit 'putstatic *this-class* g +lisp-object+)
    3053         (setf *static-code* *code*)
    3054         (setf (gethash local-function ht) g)))
    3055     g))
    3056 
    3057 (defknown declare-fixnum (fixnum) string)
    3058 (defun declare-fixnum (n)
    3059   (declare (type fixnum n))
    3060   (let* ((ht *declared-integers*)
    3061          (g (gethash1 n ht)))
    3062     (declare (type hash-table ht))
    3063     (unless g
    3064       (let ((*code* *static-code*))
    3065         (setf g (format nil "FIXNUM_~A~D"
    3066                         (if (minusp n) "MINUS_" "")
    3067                         (abs n)))
    3068         (declare-field g +lisp-fixnum+)
    3069         (cond ((<= 0 n 255)
    3070                (emit 'getstatic +lisp-fixnum-class+ "constants" +lisp-fixnum-array+)
    3071                (emit 'sipush n)
    3072                (emit 'aaload))
    3073               (t
    3074                (emit 'new +lisp-fixnum-class+)
    3075                (emit 'dup)
    3076                (case n
    3077                  (-1
    3078                   (emit 'iconst_m1))
    3079                  (0
    3080                   (emit 'iconst_0))
    3081                  (1
    3082                   (emit 'iconst_1))
    3083                  (2
    3084                   (emit 'iconst_2))
    3085                  (3
    3086                   (emit 'iconst_3))
    3087                  (4
    3088                   (emit 'iconst_4))
    3089                  (5
    3090                   (emit 'iconst_5))
    3091                  (t
    3092                   (emit-push-constant-int n)))
    3093                (emit-invokespecial-init +lisp-fixnum-class+ '("I"))))
    3094         (emit 'putstatic *this-class* g +lisp-fixnum+)
    3095         (setf *static-code* *code*)
    3096         (setf (gethash n ht) g)))
    3097     g))
    3098 
    3099 (defknown declare-bignum (integer) string)
    3100 (defun declare-bignum (n)
    3101   (let* ((ht *declared-integers*)
    3102          (g (gethash1 n ht)))
    3103     (declare (type hash-table ht))
    3104     (unless g
    3105       (cond ((<= most-negative-java-long n most-positive-java-long)
    3106              (let ((*code* *static-code*))
    3107                (setf g (format nil "BIGNUM_~A~D"
    3108                                (if (minusp n) "MINUS_" "")
    3109                                (abs n)))
    3110                (declare-field g +lisp-bignum+)
    3111                (emit 'new +lisp-bignum-class+)
    3112                (emit 'dup)
    3113                (emit 'ldc2_w (pool-long n))
    3114                (emit-invokespecial-init +lisp-bignum-class+ '("J"))
    3115                (emit 'putstatic *this-class* g +lisp-bignum+)
    3116                (setf *static-code* *code*)))
    3117             (t
    3118              (let* ((*print-base* 10)
    3119                     (s (with-output-to-string (stream) (dump-form n stream)))
    3120                     (*code* *static-code*))
    3121                (setf g (concatenate 'string "BIGNUM_" (symbol-name (gensym))))
    3122                (declare-field g +lisp-bignum+)
    3123                (emit 'new +lisp-bignum-class+)
    3124                (emit 'dup)
    3125                (emit 'ldc (pool-string s))
    3126                (emit 'bipush 10)
    3127                (emit-invokespecial-init +lisp-bignum-class+ (list +java-string+ "I"))
    3128                (emit 'putstatic *this-class* g +lisp-bignum+)
    3129                (setf *static-code* *code*))))
    3130       (setf (gethash n ht) g))
    3131     g))
    3132 
    3133 (defknown declare-character (t) string)
    3134 (defun declare-character (c)
    3135   (let ((g (symbol-name (gensym)))
    3136         (n (char-code c))
    3137         (*code* *static-code*))
    3138     (declare-field g +lisp-character+)
    3139     (cond ((<= 0 n 255)
    3140            (emit 'getstatic +lisp-character-class+ "constants" +lisp-character-array+)
    3141            (emit 'sipush n)
    3142            (emit 'aaload))
    3143           (t
    3144            (emit 'new +lisp-character-class+)
    3145            (emit 'dup)
    3146            (emit-push-constant-int n)
    3147            (emit-invokespecial-init +lisp-character-class+ '("C"))))
    3148     (emit 'putstatic *this-class* g +lisp-character+)
    3149     (setf *static-code* *code*)
    3150     g))
    3151 
    3152 (defknown declare-object-as-string (t) string)
    3153 (defun declare-object-as-string (obj)
    3154   (let* ((g (symbol-name (gensym)))
    3155          (s (with-output-to-string (stream) (dump-form obj stream)))
    3156          (*code* *static-code*))
    3157     (declare-field g +lisp-object+)
    3158     (emit 'ldc (pool-string s))
    3159     (emit-invokestatic +lisp-class+ "readObjectFromString"
    3160                        (list +java-string+) +lisp-object+)
    3161     (emit 'putstatic *this-class* g +lisp-object+)
    3162     (setf *static-code* *code*)
    3163     g))
    3164 
    3165 (defun declare-load-time-value (obj)
    3166   (let* ((g (symbol-name (gensym)))
    3167          (s (with-output-to-string (stream) (dump-form obj stream)))
    3168          (*code* *static-code*))
    3169     (declare-field g +lisp-object+)
    3170     (emit 'ldc (pool-string s))
    3171     (emit-invokestatic +lisp-class+ "readObjectFromString"
    3172                        (list +java-string+) +lisp-object+)
    3173     (emit-invokestatic +lisp-class+ "loadTimeValue"
    3174                        (lisp-object-arg-types 1) +lisp-object+)
    3175     (emit 'putstatic *this-class* g +lisp-object+)
    3176     (setf *static-code* *code*)
    3177     g))
    3178 
    3179 (defknown declare-instance (t) t)
    3180 (defun declare-instance (obj)
    3181   (aver (not (null *compile-file-truename*)))
    3182   (aver (or (structure-object-p obj) (standard-object-p obj)
    3183             (java:java-object-p obj)))
    3184   (let* ((g (symbol-name (gensym)))
    3185          (s (with-output-to-string (stream) (dump-form obj stream)))
    3186          (*code* *static-code*))
    3187     (declare-field g +lisp-object+)
    3188     (emit 'ldc (pool-string s))
    3189     (emit-invokestatic +lisp-class+ "readObjectFromString"
    3190                        (list +java-string+) +lisp-object+)
    3191     (emit-invokestatic +lisp-class+ "loadTimeValue"
    3192                        (lisp-object-arg-types 1) +lisp-object+)
    3193     (emit 'putstatic *this-class* g +lisp-object+)
    3194     (setf *static-code* *code*)
    3195     g))
    3196 
    3197 (defun declare-package (obj)
    3198   (let* ((g (symbol-name (gensym)))
    3199          (*print-level* nil)
    3200          (*print-length* nil)
    3201          (s (format nil "#.(FIND-PACKAGE ~S)" (package-name obj)))
    3202          (*code* *static-code*))
    3203     (declare-field g +lisp-object+)
    3204     (emit 'ldc (pool-string s))
    3205     (emit-invokestatic +lisp-class+ "readObjectFromString"
    3206                        (list +java-string+) +lisp-object+)
    3207     (emit 'putstatic *this-class* g +lisp-object+)
    3208     (setf *static-code* *code*)
    3209     g))
    3210 
    3211 (declaim (ftype (function (t) string) declare-object))
    3212 (defun declare-object (obj)
    3213   (let ((key (symbol-name (gensym))))
    3214     (remember key obj)
    3215     (let* ((g1 (declare-string key))
    3216            (g2 (symbol-name (gensym)))
    3217            (*code* *static-code*))
    3218       (declare-field g2 +lisp-object+)
    3219       (emit 'getstatic *this-class* g1 +lisp-simple-string+)
    3220       (emit-invokestatic +lisp-class+ "recall"
    3221                          (list +lisp-simple-string+) +lisp-object+)
    3222       (emit 'putstatic *this-class* g2 +lisp-object+)
    3223       (setf *static-code* *code*)
    3224       g2)))
    3225 
    3226 (defun declare-lambda (obj)
    3227   (let* ((g (symbol-name (gensym)))
    3228          (*print-level* nil)
    3229          (*print-length* nil)
    3230          (s (format nil "~S" obj))
    3231          (*code* *static-code*))
    3232     (declare-field g +lisp-object+)
    3233     (emit 'ldc
    3234           (pool-string s))
    3235     (emit-invokestatic +lisp-class+ "readObjectFromString"
    3236                        (list +java-string+) +lisp-object+)
    3237     (emit-invokestatic +lisp-class+ "coerceToFunction"
    3238                        (lisp-object-arg-types 1) +lisp-object+)
    3239     (emit 'putstatic *this-class* g +lisp-object+)
    3240     (setf *static-code* *code*)
    3241     g))
    3242 
    3243 (defun declare-string (string)
    3244   (let* ((ht *declared-strings*)
    3245          (g (gethash1 string ht)))
    3246     (declare (type hash-table ht))
    3247     (unless g
    3248       (let ((*code* *static-code*))
    3249         (setf g (symbol-name (gensym)))
    3250         (declare-field g +lisp-simple-string+)
    3251         (emit 'new +lisp-simple-string-class+)
    3252         (emit 'dup)
    3253         (emit 'ldc (pool-string string))
    3254         (emit-invokespecial-init +lisp-simple-string-class+ (list +java-string+))
    3255         (emit 'putstatic *this-class* g +lisp-simple-string+)
    3256         (setf *static-code* *code*)
    3257         (setf (gethash string ht) g)))
    3258     g))
    3259 
    3260 (defknown compile-constant (t t t) t)
    3261 (defun compile-constant (form target representation)
    3262   (unless target
    3263     (return-from compile-constant))
    3264   (case representation
    3265     (:int
    3266      (cond ((fixnump form)
    3267             (emit-push-constant-int form)
    3268             (emit-move-from-stack target representation)
    3269             (return-from compile-constant))
    3270            ((integerp form)
    3271             (emit 'getstatic *this-class* (declare-bignum form) +lisp-bignum+)
    3272             (emit-invokevirtual +lisp-object-class+ "intValue" nil "I")
    3273             (emit-move-from-stack target representation)
    3274             (return-from compile-constant))
    3275            (t
    3276             (assert nil))))
    3277     (:long
    3278      (cond ((fixnump form)
    3279             (case form
    3280               (0
    3281                (emit 'lconst_0))
    3282               (1
    3283                (emit 'lconst_1))
    3284               (t
    3285                (emit-push-constant-int form)
    3286                (emit 'i2l)))
    3287             (emit-move-from-stack target representation)
    3288             (return-from compile-constant))
    3289            ((<= most-negative-java-long form most-positive-java-long)
    3290             (emit 'ldc2_w (pool-long form))
    3291             (return-from compile-constant))
    3292            ((integerp form)
    3293             (emit 'getstatic *this-class* (declare-bignum form) +lisp-bignum+)
    3294             (emit-invokevirtual +lisp-object-class+ "longValue" nil "J")
    3295             (emit-move-from-stack target representation)
    3296             (return-from compile-constant))
    3297            (t
    3298             (assert nil))))
    3299     (:char
    3300      (cond ((characterp form)
    3301             (emit-push-constant-int (char-code form))
    3302             (emit-move-from-stack target representation)
    3303             (return-from compile-constant))
    3304            (t
    3305             (assert nil))))
    3306     (:boolean
    3307      (emit (if form 'iconst_1 'iconst_0))
    3308      (emit-move-from-stack target representation)
    3309      (return-from compile-constant)))
    3310   (cond ((fixnump form)
    3311          (let ((translation (case form
    3312                               (0  "ZERO")
    3313                               (1  "ONE")
    3314                               (2  "TWO")
    3315                               (3  "THREE")
    3316                               (-1 "MINUS_ONE"))))
    3317            (if translation
    3318                (emit 'getstatic +lisp-fixnum-class+ translation +lisp-fixnum+)
    3319                (emit 'getstatic *this-class* (declare-fixnum form) +lisp-fixnum+))))
    3320         ((integerp form)
    3321          ;; A bignum.
    3322          (emit 'getstatic *this-class* (declare-bignum form) +lisp-bignum+))
    3323         ((numberp form)
    3324          ;; A number, but not a fixnum.
    3325          (emit 'getstatic *this-class*
    3326                (declare-object-as-string form) +lisp-object+))
    3327         ((stringp form)
    3328          (if *compile-file-truename*
    3329              (emit 'getstatic *this-class*
    3330                    (declare-string form) +lisp-simple-string+)
    3331              (emit 'getstatic *this-class*
    3332                    (declare-object form) +lisp-object+)))
    3333         ((vectorp form)
    3334          (if *compile-file-truename*
    3335              (emit 'getstatic *this-class*
    3336                    (declare-object-as-string form) +lisp-object+)
    3337              (emit 'getstatic *this-class*
    3338                    (declare-object form) +lisp-object+)))
    3339         ((characterp form)
    3340          (emit 'getstatic *this-class*
    3341                (declare-character form) +lisp-character+))
    3342         ((or (hash-table-p form) (typep form 'generic-function))
    3343          (emit 'getstatic *this-class*
    3344                (declare-object form) +lisp-object+))
    3345         ((pathnamep form)
    3346          (let ((g (if *compile-file-truename*
    3347                       (declare-object-as-string form)
    3348                       (declare-object form))))
    3349            (emit 'getstatic *this-class* g +lisp-object+)))
    3350         ((packagep form)
    3351          (let ((g (if *compile-file-truename*
    3352                       (declare-package form)
    3353                       (declare-object form))))
    3354            (emit 'getstatic *this-class* g +lisp-object+)))
    3355         ((or (structure-object-p form)
    3356              (standard-object-p form)
    3357              (java:java-object-p form))
    3358          (let ((g (if *compile-file-truename*
    3359                       (declare-instance form)
    3360                       (declare-object form))))
    3361            (emit 'getstatic *this-class* g +lisp-object+)))
    3362         (t
    3363          (if *compile-file-truename*
    3364              (error "COMPILE-CONSTANT unhandled case ~S" form)
    3365              (emit 'getstatic *this-class*
    3366                    (declare-object form) +lisp-object+))))
    3367   (emit-move-from-stack target representation))
    3368 
    3369 (defparameter *unary-operators* nil)
    3370 
    3371 (defun initialize-unary-operators ()
    3372   (let ((ht (make-hash-table :test 'eq)))
    3373     (dolist (pair '((ABS             "ABS")
    3374                     (CADDR           "caddr")
    3375                     (CADR            "cadr")
    3376                     (CDDR            "cddr")
    3377                     (CDR             "cdr")
    3378                     (CLASS-OF        "classOf")
    3379                     (COMPLEXP        "COMPLEXP")
    3380                     (DENOMINATOR     "DENOMINATOR")
    3381                     (FIRST           "car")
    3382                     (LENGTH          "LENGTH")
    3383                     (NREVERSE        "nreverse")
    3384                     (NUMERATOR       "NUMERATOR")
    3385                     (REST            "cdr")
    3386                     (REVERSE         "reverse")
    3387                     (SECOND          "cadr")
    3388                     (SIMPLE-STRING-P "SIMPLE_STRING_P")
    3389                     (STRING          "STRING")
    3390                     (THIRD           "caddr")))
    3391       (setf (gethash (%car pair) ht) (%cadr pair)))
    3392     (setf *unary-operators* ht)))
    3393 
    3394 (initialize-unary-operators)
    3395 
    3396 (defknown install-p2-handler * t)
    3397 (defun install-p2-handler (symbol &optional handler)
    3398   (declare (type symbol symbol))
    3399   (let ((handler (or handler
    3400                      (find-symbol (concatenate 'string "COMPILE-" (symbol-name symbol)) 'jvm))))
    3401     (unless (and handler (fboundp handler))
    3402       (error "Handler not found: ~S" handler))
    3403     (setf (get symbol 'p2-handler) handler)))
    3404 
    3405 (defparameter *predicates* (make-hash-table :test 'eq))
    3406 
    3407 (defun define-predicate (name boxed-method-name unboxed-method-name)
    3408   (setf (gethash name *predicates*) (cons boxed-method-name unboxed-method-name))
    3409   (install-p2-handler name 'p2-predicate))
    3410 
    3411 (defknown p2-predicate (t t t) t)
    3412 (defun p2-predicate (form target representation)
    3413   (unless (= (length form) 2)
    3414     (compile-function-call form target representation)
    3415     (return-from p2-predicate))
    3416   (let* ((op (car form))
    3417          (info (gethash op *predicates*))
    3418          (boxed-method-name (car info))
    3419          (unboxed-method-name (cdr info)))
    3420     (cond ((and boxed-method-name unboxed-method-name)
    3421            (let ((arg (cadr form)))
    3422              (compile-form arg 'stack nil)
    3423              (maybe-emit-clear-values arg)
    3424              (case representation
    3425                (:boolean
    3426                 (emit-invokevirtual +lisp-object-class+
    3427                                     unboxed-method-name
    3428                                     nil "Z"))
    3429                (t
    3430                 (emit-invokevirtual +lisp-object-class+
    3431                                     boxed-method-name
    3432                                     nil +lisp-object+)))
    3433              (emit-move-from-stack target representation)))
    3434           (t
    3435            (compile-function-call form target representation)))))
    3436 
    3437 (define-predicate 'constantp "CONSTANTP" "constantp")
    3438 (define-predicate 'endp      "ENDP"      "endp")
    3439 (define-predicate 'evenp     "EVENP"     "evenp")
    3440 (define-predicate 'floatp    "FLOATP"    "floatp")
    3441 (define-predicate 'integerp  "INTEGERP"  "integerp")
    3442 (define-predicate 'listp     "LISTP"     "listp")
    3443 (define-predicate 'minusp    "MINUSP"    "minusp")
    3444 (define-predicate 'numberp   "NUMBERP"   "numberp")
    3445 (define-predicate 'oddp      "ODDP"      "oddp")
    3446 (define-predicate 'plusp     "PLUSP"     "plusp")
    3447 (define-predicate 'rationalp "RATIONALP" "rationalp")
    3448 (define-predicate 'realp     "REALP"     "realp")
    3449 
    3450 (declaim (ftype (function (t t t t) t) compile-function-call-1))
    3451 (defun compile-function-call-1 (op args target representation)
    3452   (let ((arg (first args)))
    3453     (when (eq op '1+)
    3454       (p2-plus (list '+ arg 1) target representation)
    3455       (return-from compile-function-call-1 t))
    3456     (when (eq op '1-)
    3457       (p2-minus (list '- arg 1) target representation)
    3458       (return-from compile-function-call-1 t))
    3459     (let ((s (gethash1 op (the hash-table *unary-operators*))))
    3460       (cond (s
    3461              (compile-form arg 'stack nil)
    3462              (maybe-emit-clear-values arg)
    3463              (emit-invoke-method s target representation)
    3464              t)
    3465             (t
    3466              nil)))))
    3467 
    3468 (defparameter *binary-operators* nil)
    3469 
    3470 (defun initialize-binary-operators ()
    3471   (let ((ht (make-hash-table :test 'eq)))
    3472     (dolist (pair '((EQL          "EQL")
    3473                     (EQUAL        "EQUAL")
    3474                     (+            "add")
    3475                     (-            "subtract")
    3476                     (/            "divideBy")
    3477                     (*            "multiplyBy")
    3478                     (<            "IS_LT")
    3479                     (<=           "IS_LE")
    3480                     (>            "IS_GT")
    3481                     (>=           "IS_GE")
    3482                     ( =           "IS_E")
    3483                     (/=           "IS_NE")
    3484                     (ASH          "ash")
    3485                     (AREF         "AREF")
    3486                     (SIMPLE-TYPEP "typep")
    3487                     (RPLACA       "RPLACA")
    3488                     (RPLACD       "RPLACD")))
    3489       (setf (gethash (%car pair) ht) (%cadr pair)))
    3490     (setf *binary-operators* ht)))
    3491 
    3492 (initialize-binary-operators)
    3493 
    3494 (defun compile-binary-operation (op args target representation)
    3495   (let ((arg1 (car args))
    3496         (arg2 (cadr args)))
    3497   (compile-form arg1 'stack nil)
    3498   (compile-form arg2 'stack nil)
    3499   (maybe-emit-clear-values arg1 arg2)
    3500   (emit-invokevirtual +lisp-object-class+ op
    3501                       (lisp-object-arg-types 1) +lisp-object+)
    3502   (fix-boxing representation nil)
    3503   (emit-move-from-stack target representation)))
    3504 
    3505 (declaim (ftype (function (t t t t) t) compile-function-call-2))
    3506 (defun compile-function-call-2 (op args target representation)
    3507   (let ((translation (gethash1 op (the hash-table *binary-operators*))))
    3508     (when translation
    3509       (compile-binary-operation translation args target representation))))
    3510 
    3511 (declaim (ftype (function (t) t) fixnum-or-unboxed-variable-p))
    3512 (defun fixnum-or-unboxed-variable-p (arg)
    3513   (or (fixnump arg)
    3514       (unboxed-fixnum-variable arg)))
    3515 
    3516 (declaim (ftype (function (t) t) emit-push-int))
    3517 (defun emit-push-int (arg)
    3518   (if (fixnump arg)
    3519       (emit-push-constant-int arg)
    3520       (let ((variable (unboxed-fixnum-variable arg)))
    3521         (if variable
    3522             (emit 'iload (variable-register variable))
    3523             (aver nil)))))
    3524 
    3525 (declaim (ftype (function (t) t) emit-push-long))
    3526 (defun emit-push-long (arg)
    3527   (cond ((eql arg 0)
    3528          (emit 'lconst_0))
    3529         ((eql arg 1)
    3530          (emit 'lconst_1))
    3531         ((fixnump arg)
    3532          (emit-push-constant-int arg)
    3533          (emit 'i2l))
    3534         (t
    3535          (let ((variable (unboxed-fixnum-variable arg)))
    3536            (aver (not (null variable)))
    3537            (aver (not (null (variable-register variable))))
    3538            (emit 'iload (variable-register variable))
    3539            (emit 'i2l)))))
    3540 
    3541 (defknown p2-eq/neq (t t t) t)
    3542 (defun p2-eq/neq (form target representation)
    3543   (aver (or (null representation) (eq representation :boolean)))
    3544   (unless (check-arg-count form 2)
    3545     (compile-function-call form target representation)
    3546     (return-from p2-eq/neq))
    3547   (let* ((op (%car form))
    3548          (args (%cdr form))
    3549          (arg1 (%car args))
    3550          (arg2 (%cadr args)))
    3551      (compile-form arg1 'stack nil)
    3552      (compile-form arg2 'stack nil)
    3553      (maybe-emit-clear-values arg1 arg2)
    3554      (let ((LABEL1 (gensym))
    3555            (LABEL2 (gensym)))
    3556        (emit (if (eq op 'EQ) 'if_acmpne 'if_acmpeq) `,LABEL1)
    3557        (emit-push-true representation)
    3558        (emit 'goto `,LABEL2)
    3559        (label `,LABEL1)
    3560        (emit-push-false representation)
    3561        (label `,LABEL2))
    3562      (emit-move-from-stack target representation))
    3563    t)
    3564 
    3565 (defknown p2-eql (t t t) t)
    3566 (defun p2-eql (form target representation)
    3567   (aver (or (null representation) (eq representation :boolean)))
    3568   (unless (check-arg-count form 2)
    3569     (compile-function-call form target representation)
    3570     (return-from p2-eql))
    3571   (let* ((arg1 (%cadr form))
    3572          (arg2 (%caddr form))
    3573          (type1 (derive-compiler-type arg1))
    3574          (type2 (derive-compiler-type arg2)))
    3575     (cond ((and (fixnum-type-p type1)
    3576                 (fixnum-type-p type2))
    3577            (compile-form arg1 'stack :int)
    3578            (compile-form arg2 'stack :int)
    3579            (maybe-emit-clear-values arg1 arg2)
    3580            (let ((label1 (gensym))
    3581                  (label2 (gensym)))
    3582              (emit 'if_icmpeq `,label1)
    3583              (emit-push-false representation)
    3584              (emit 'goto `,label2)
    3585              (emit 'label `,label1)
    3586              (emit-push-true representation)
    3587              (emit 'label `,label2)))
    3588           ((fixnum-type-p type2)
    3589            (compile-form arg1 'stack nil)
    3590            (compile-form arg2 'stack :int)
    3591            (maybe-emit-clear-values arg1 arg2)
    3592            (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z")
    3593            (case representation
    3594              (:boolean)
    3595              (t
    3596               (let ((label1 (gensym))
    3597                     (label2 (gensym)))
    3598                 (emit 'ifne `,label1)
    3599                 (emit-push-nil)
    3600                 (emit 'goto `,label2)
    3601                 (emit 'label `,label1)
    3602                 (emit-push-t)
    3603                 (emit 'label `,label2)))))
    3604           ((fixnum-type-p type1)
    3605            (compile-form arg1 'stack :int)
    3606            (compile-form arg2 'stack nil)
    3607            (maybe-emit-clear-values arg1 arg2)
    3608            (emit 'swap)
    3609            (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z")
    3610            (case representation
    3611              (:boolean)
    3612              (t
    3613               (let ((label1 (gensym))
    3614                     (label2 (gensym)))
    3615                 (emit 'ifne `,label1)
    3616                 (emit-push-nil)
    3617                 (emit 'goto `,label2)
    3618                 (emit 'label `,label1)
    3619                 (emit-push-t)
    3620                 (emit 'label `,label2)))))
    3621           ((eq type2 'CHARACTER)
    3622            (compile-form arg1 'stack nil)
    3623            (compile-form arg2 'stack :char)
    3624            (maybe-emit-clear-values arg1 arg2)
    3625            (emit-invokevirtual +lisp-object-class+ "eql" '("C") "Z")
    3626            (case representation
    3627              (:boolean)
    3628              (t
    3629               (let ((label1 (gensym))
    3630                     (label2 (gensym)))
    3631                 (emit 'ifne `,label1)
    3632                 (emit-push-nil)
    3633                 (emit 'goto `,label2)
    3634                 (emit 'label `,label1)
    3635                 (emit-push-t)
    3636                 (emit 'label `,label2)))))
    3637           ((eq type1 'CHARACTER)
    3638            (compile-form arg1 'stack :char)
    3639            (compile-form arg2 'stack nil)
    3640            (maybe-emit-clear-values arg1 arg2)
    3641            (emit 'swap)
    3642            (emit-invokevirtual +lisp-object-class+ "eql" '("C") "Z")
    3643            (case representation
    3644              (:boolean)
    3645              (t
    3646               (let ((label1 (gensym))
    3647                     (label2 (gensym)))
    3648                 (emit 'ifne `,label1)
    3649                 (emit-push-nil)
    3650                 (emit 'goto `,label2)
    3651                 (emit 'label `,label1)
    3652                 (emit-push-t)
    3653                 (emit 'label `,label2)))))
    3654           (t
    3655            (compile-form arg1 'stack nil)
    3656            (compile-form arg2 'stack nil)
    3657            (maybe-emit-clear-values arg1 arg2)
    3658            (case representation
    3659              (:boolean
    3660               (emit-invokevirtual +lisp-object-class+ "eql"
    3661                                   (lisp-object-arg-types 1) "Z"))
    3662              (t
    3663               (emit-invokevirtual +lisp-object-class+ "EQL"
    3664                                   (lisp-object-arg-types 1) +lisp-object+)))))
    3665     (emit-move-from-stack target representation)))
    3666 
    3667 (defknown p2-memq (t t t) t)
    3668 (defun p2-memq (form target representation)
    3669 ;;   (format t "p2-memq representation = ~S~%" representation)
    3670   (unless (check-arg-count form 2)
    3671     (compile-function-call form target representation)
    3672     (return-from p2-memq))
    3673   (cond ((eq representation :boolean)
    3674          (let* ((args (cdr form))
    3675                 (arg1 (first args))
    3676                 (arg2 (second args)))
    3677            (compile-form arg1 'stack nil)
    3678            (compile-form arg2 'stack nil)
    3679            (emit-invokestatic +lisp-class+ "memq"
    3680                               (lisp-object-arg-types 2) "Z")
    3681            (emit-move-from-stack target representation)))
    3682         (t
    3683          (compile-function-call form target representation))))
    3684 
    3685 (defknown p2-memql (t t t) t)
    3686 (defun p2-memql (form target representation)
    3687   (unless (check-arg-count form 2)
    3688     (compile-function-call form target representation)
    3689     (return-from p2-memql))
    3690   (cond ((eq representation :boolean)
    3691          (let* ((args (cdr form))
    3692                 (arg1 (first args))
    3693                 (arg2 (second args))
    3694                 (type1 (derive-compiler-type arg1)))
    3695            (compile-form arg1 'stack nil)
    3696            (compile-form arg2 'stack nil)
    3697            (cond ((eq type1 'SYMBOL) ; FIXME
    3698                   (emit-invokestatic +lisp-class+ "memq"
    3699                                      (lisp-object-arg-types 2) "Z"))
    3700                  (t
    3701                   (emit-invokestatic +lisp-class+ "memql"
    3702                                      (lisp-object-arg-types 2) "Z")))
    3703            (emit-move-from-stack target representation)))
    3704         (t
    3705          (compile-function-call form target representation))))
    3706 
    3707 (defun p2-gensym (form target representation)
    3708   (cond ((and (null representation) (null (cdr form)))
    3709          (emit-push-current-thread)
    3710          (emit-invokestatic +lisp-class+ "gensym"
    3711                             (list +lisp-thread+) +lisp-symbol+)
    3712          (emit-move-from-stack target))
    3713         (t
    3714          (compile-function-call form target representation))))
    3715 
    3716 ;; get symbol indicator &optional default => value
    3717 (defun p2-get (form target representation)
    3718   (let* ((args (cdr form))
    3719          (arg1 (first args))
    3720          (arg2 (second args))
    3721          (arg3 (third args)))
    3722     (case (length args)
    3723       ((2 3)
    3724        (compile-form arg1 'stack nil)
    3725        (compile-form arg2 'stack nil)
    3726        (cond ((null arg3)
    3727               (maybe-emit-clear-values arg1 arg2))
    3728              (t
    3729               (compile-form arg3 'stack nil)
    3730               (maybe-emit-clear-values arg1 arg2 arg3)))
    3731        (emit-invokestatic +lisp-class+ "get"
    3732                           (lisp-object-arg-types (if arg3 3 2))
    3733                           +lisp-object+)
    3734        (fix-boxing representation nil)
    3735        (emit-move-from-stack target representation))
    3736       (t
    3737        (compiler-warn "Wrong number of arguments for ~A (expected 2 or 3, but received ~D)."
    3738                     'GET (length args))
    3739        (compile-function-call form target representation)))))
    3740 
    3741 ;; getf plist indicator &optional default => value
    3742 (defun p2-getf (form target representation)
    3743   (let* ((args (cdr form))
    3744          (arg-count (length args)))
    3745     (case arg-count
    3746       ((2 3)
    3747        (let ((arg1 (first args))
    3748              (arg2 (second args))
    3749              (arg3 (third args)))
    3750          (compile-form arg1 'stack nil)
    3751          (compile-form arg2 'stack nil)
    3752          (compile-form arg3 'stack nil)
    3753          (maybe-emit-clear-values arg1 arg2 arg3)
    3754          (emit-invokestatic +lisp-class+ "getf"
    3755                             (lisp-object-arg-types 3) +lisp-object+)
    3756          (fix-boxing representation nil)
    3757          (emit-move-from-stack target representation)))
    3758       (t
    3759        (compile-function-call form target representation)))))
    3760 
    3761 ;; gethash key hash-table &optional default => value, present-p
    3762 (defun p2-gethash (form target representation)
    3763   (cond ((and (eq (car form) 'GETHASH1)
    3764               (= (length form) 3)
    3765               (eq (derive-type (%caddr form)) 'HASH-TABLE))
    3766          (let ((key-form (%cadr form))
    3767                (ht-form (%caddr form)))
    3768            (compile-form ht-form 'stack nil)
    3769            (emit 'checkcast +lisp-hash-table-class+)
    3770            (compile-form key-form 'stack nil)
    3771            (maybe-emit-clear-values ht-form key-form)
    3772            (emit-invokevirtual +lisp-hash-table-class+ "gethash1"
    3773                                (lisp-object-arg-types 1) +lisp-object+)
    3774            (fix-boxing representation nil)
    3775            (emit-move-from-stack target representation)))
    3776         (t
    3777          (compile-function-call form target representation))))
    3778 
    3779 ;; puthash key hash-table new-value &optional default => value
    3780 (defun p2-puthash (form target representation)
    3781   (cond ((and (= (length form) 4)
    3782               (eq (derive-type (%caddr form)) 'HASH-TABLE))
    3783          (let ((key-form (%cadr form))
    3784                (ht-form (%caddr form))
    3785                (value-form (fourth form)))
    3786            (compile-form ht-form 'stack nil)
    3787            (emit 'checkcast +lisp-hash-table-class+)
    3788            (compile-form key-form 'stack nil)
    3789            (compile-form value-form 'stack nil)
    3790            (maybe-emit-clear-values ht-form key-form value-form)
    3791            (cond (target
    3792                   (emit-invokevirtual +lisp-hash-table-class+ "puthash"
    3793                                       (lisp-object-arg-types 2) +lisp-object+)
    3794                   (fix-boxing representation nil)
    3795                   (emit-move-from-stack target representation))
    3796                  (t
    3797                   (emit-invokevirtual +lisp-hash-table-class+ "put"
    3798                                       (lisp-object-arg-types 2) nil)))))
    3799         (t
    3800          (compile-function-call form target representation))))
    3801 
    3802 (defvar *functions-defined-in-current-file* nil)
    3803 
    3804 (defun inline-ok (name)
    3805   (declare (optimize speed))
    3806   (cond ((notinline-p name)
    3807          nil)
    3808         ((built-in-function-p name)
    3809          t)
    3810         ((memq name *functions-defined-in-current-file*)
    3811          t)
    3812         (t
    3813          nil)))
    3814 
    3815 (defknown process-args (t) t)
    3816 (defun process-args (args)
    3817   ""
    3818   (when args
    3819     (let ((numargs (length args)))
    3820       (let ((must-clear-values nil))
    3821         (declare (type boolean must-clear-values))
    3822         (cond ((<= numargs call-registers-limit)
    3823                (dolist (arg args)
    3824                  (compile-form arg 'stack nil)
    3825                  (unless must-clear-values
    3826                    (unless (single-valued-p arg)
    3827                      (setf must-clear-values t)))))
    3828               (t
    3829                (emit 'sipush numargs)
    3830                (emit 'anewarray +lisp-object-class+)
    3831                (let ((i 0))
    3832                  (dolist (arg args)
    3833                    (emit 'dup)
    3834                    (emit 'sipush i)
    3835                    (compile-form arg 'stack nil)
    3836                    (emit 'aastore) ; store value in array
    3837                    (unless must-clear-values
    3838                      (unless (single-valued-p arg)
    3839                        (setf must-clear-values t)))
    3840                    (incf i)))))
    3841         (when must-clear-values
    3842           (emit-clear-values)))))
    3843   t)
    3844 
    3845 (defknown lisp-object-arg-types (fixnum) list)
    3846 (let ((table (make-array 10)))
    3847   (dotimes (i 10)
    3848     (declare (type fixnum i))
    3849     (setf (aref table i) (make-list i :initial-element +lisp-object+)))
    3850   (defun lisp-object-arg-types (n)
    3851     (declare (type fixnum n))
    3852     (declare (optimize speed (safety 0)))
    3853     (if (< n 10)
    3854         (aref table n)
    3855         (make-list n :initial-element +lisp-object+))))
    3856 
    3857 (declaim (ftype (function (t) t) emit-call-execute))
    3858 (defun emit-call-execute (numargs)
    3859   (let ((arg-types (if (<= numargs call-registers-limit)
    3860                        (lisp-object-arg-types numargs)
    3861                        (list +lisp-object-array+)))
    3862         (return-type +lisp-object+))
    3863     (emit-invokevirtual +lisp-object-class+ "execute" arg-types return-type)))
    3864 
    3865 (declaim (ftype (function (t) t) emit-call-thread-execute))
    3866 (defun emit-call-thread-execute (numargs)
    3867   (let ((arg-types (if (<= numargs call-registers-limit)
    3868                        (lisp-object-arg-types (1+ numargs))
    3869                        (list +lisp-object+ +lisp-object-array+)))
    3870         (return-type +lisp-object+))
    3871     (emit-invokevirtual +lisp-thread-class+ "execute" arg-types return-type)))
    3872 
    3873 (defknown compile-function-call (t t t) t)
    3874 (defun compile-function-call (form target representation)
    3875   (let ((op (car form))
    3876         (args (cdr form)))
    3877     (declare (type symbol op))
    3878     (when (find-local-function op)
    3879       (return-from compile-function-call
    3880                    (compile-local-function-call form target representation)))
    3881     (when (and (boundp '*defined-functions*) (boundp '*undefined-functions*))
    3882       (unless (or (fboundp op)
    3883                   (eq op (compiland-name *current-compiland*))
    3884                   (memq op *defined-functions*)
    3885                   (proclaimed-ftype op))
    3886         (pushnew op *undefined-functions*)))
    3887     (let ((numargs (length args)))
    3888       (case numargs
    3889         (1
    3890          (when (compile-function-call-1 op args target representation)
    3891            (return-from compile-function-call)))
    3892         (2
    3893          (when (compile-function-call-2 op args target representation)
    3894            (return-from compile-function-call))))
    3895       (let ((explain *explain*))
    3896         (when (and explain (memq :calls explain))
    3897           (let ((package (symbol-package op)))
    3898             (when (or (eq package +cl-package+) (eq package (find-package "SYSTEM")))
    3899               (format t ";   full call to ~S~%" op)))))
    3900       (when (or (<= *speed* *debug*) *require-stack-frame*)
    3901         (emit-push-current-thread))
    3902       (cond ((eq op (compiland-name *current-compiland*)) ; recursive call
    3903              (if (notinline-p op)
    3904                  (emit 'getstatic *this-class* (declare-symbol op) +lisp-symbol+)
    3905                  (emit 'aload 0)))
    3906             ((null (symbol-package op))
    3907              (let ((g (if *compile-file-truename*
    3908                           (declare-object-as-string op)
    3909                           (declare-object op))))
    3910                (emit 'getstatic *this-class* g +lisp-object+)))
    3911             (t
    3912              (let ((name (lookup-known-symbol op)))
    3913                (if name
    3914                    (emit 'getstatic +lisp-symbol-class+ name +lisp-symbol+)
    3915                    (emit 'getstatic *this-class* (declare-symbol op) +lisp-symbol+)))))
    3916       (process-args args)
    3917       (if (or (<= *speed* *debug*) *require-stack-frame*)
    3918           (emit-call-thread-execute numargs)
    3919           (emit-call-execute numargs))
    3920       (fix-boxing representation (derive-compiler-type form))
    3921       (emit-move-from-stack target representation))))
    3922 
    3923 (defun compile-call (args)
    3924   (let ((numargs (length args)))
    3925     (cond ((> *speed* *debug*)
    3926            (process-args args)
    3927            (emit-call-execute numargs))
    3928           (t
    3929            (emit-push-current-thread)
    3930            (emit 'swap) ; Stack: thread function
    3931            (process-args args)
    3932            (emit-call-thread-execute numargs)))))
    3933 
    3934 (define-source-transform funcall (&whole form fun &rest args)
    3935   (cond ((> *debug* *speed*)
    3936          form)
    3937         ((and (consp fun)
    3938               (eq (%car fun) 'FUNCTION)
    3939               (symbolp (cadr fun)))
    3940          `(,(cadr fun) ,@args))
    3941         ((and (consp fun)
    3942               (eq (%car fun) 'QUOTE))
    3943          (let ((sym (cadr fun)))
    3944            (if (and (symbolp sym)
    3945                     (eq (symbol-package (truly-the symbol sym)) +cl-package+)
    3946                     (not (special-operator-p sym))
    3947                     (not (macro-function sym)))
    3948                `(,(cadr fun) ,@args)
    3949                form)))
    3950         (t
    3951          form)))
    3952 
    3953 (define-source-transform mapcar (&whole form function &rest lists)
    3954   (cond ((or (> *debug* *speed*)
    3955              (> *space* *speed*))
    3956          form)
    3957         ((= (length lists) 1)
    3958          (let ((list (gensym))
    3959                (result (gensym))
    3960                (temp (gensym)))
    3961            `(let* ((,list ,(car lists))
    3962                    (,result (list nil))
    3963                    (,temp ,result))
    3964               (loop
    3965                 (when (null ,list)
    3966                   (return (cdr ,result)))
    3967                 (rplacd ,temp (setf ,temp (list (funcall ,function (car ,list)))))
    3968                 (setf ,list (cdr ,list))))))
    3969         (t
    3970          form)))
    3971 
    3972 (define-source-transform mapc (&whole form function &rest lists)
    3973   (cond ((or (> *debug* *speed*)
    3974              (> *space* *speed*))
    3975          form)
    3976         ((= (length lists) 1)
    3977          (let ((list (gensym))
    3978                (result (gensym)))
    3979            `(let* ((,list ,(car lists))
    3980                    (,result ,list))
    3981               (loop
    3982                 (when (null ,list)
    3983                   (return ,result))
    3984                 (funcall ,function (car ,list))
    3985                 (setf ,list (%cdr ,list))))))
    3986         (t
    3987          form)))
    3988 
    3989 ;; (define-source-transform min (&whole form &rest args)
    3990 ;;   (cond ((= (length args) 2)
    3991 ;;          (let* ((arg1 (%car args))
    3992 ;;                 (arg2 (%cadr args))
    3993 ;;                 (sym1 (gensym))
    3994 ;;                 (sym2 (gensym)))
    3995 ;;            `(let ((,sym1 ,arg1)
    3996 ;;                   (,sym2 ,arg2))
    3997 ;;               (if (<= ,sym1 ,sym2) ,sym1 ,sym2))))
    3998 ;;         (t
    3999 ;;          form)))
    4000 
    4001 ;; (define-source-transform max (&whole form &rest args)
    4002 ;;   (cond ((= (length args) 2)
    4003 ;;          (let* ((arg1 (%car args))
    4004 ;;                 (arg2 (%cadr args))
    4005 ;;                 (sym1 (gensym))
    4006 ;;                 (sym2 (gensym)))
    4007 ;;            `(let ((,sym1 ,arg1)
    4008 ;;                   (,sym2 ,arg2))
    4009 ;;               (if (>= ,sym1 ,sym2) ,sym1 ,sym2))))
    4010 ;;         (t
    4011 ;;          form)))
    4012 
    4013 (defknown p2-funcall (t t t) t)
    4014 (defun p2-funcall (form target representation)
    4015   (unless (> (length form) 1)
    4016     (compiler-warn "Wrong number of arguments for ~A." (car form))
    4017     (compile-function-call form target representation)
    4018     (return-from p2-funcall))
    4019   (when (> *debug* *speed*)
    4020     (return-from p2-funcall (compile-function-call form target representation)))
    4021   (compile-form (cadr form) 'stack nil)
    4022   (maybe-emit-clear-values (cadr form))
    4023   (compile-call (cddr form))
    4024 ;;   (case representation
    4025 ;;     (:int (emit-unbox-fixnum))
    4026 ;;     (:char (emit-unbox-character)))
    4027   (fix-boxing representation nil)
    4028   (emit-move-from-stack target))
    4029 
    4030 (defun save-variables (variables)
    4031   (let ((saved-vars '()))
    4032     (dolist (variable variables)
    4033       (when (variable-closure-index variable)
    4034         (let ((register (allocate-register)))
    4035           (emit 'aload (compiland-closure-register *current-compiland*))
    4036           (emit-push-constant-int (variable-closure-index variable))
    4037           (emit 'aaload)
    4038           (emit 'astore register)
    4039           (push (cons variable register) saved-vars))))
    4040     saved-vars))
    4041 
    4042 (defun restore-variables (saved-vars)
    4043   (dolist (saved-var saved-vars)
    4044     (let ((variable (car saved-var))
    4045           (register (cdr saved-var)))
    4046       (emit 'aload (compiland-closure-register *current-compiland*))
    4047       (emit-push-constant-int (variable-closure-index variable))
    4048       (emit 'aload register)
    4049       (emit 'aastore))))
    4050 
    4051 (defknown compile-local-function-call (t t t) t)
    4052 (defun compile-local-function-call (form target representation)
    4053   (let* ((compiland *current-compiland*)
    4054          (op (car form))
    4055          (args (cdr form))
    4056          (local-function (find-local-function op))
    4057          (*register* *register*)
    4058          (saved-vars '()))
    4059     (cond ((local-function-variable local-function)
    4060            ;; LABELS
    4061            (dformat t "compile-local-function-call LABELS case variable = ~S~%"
    4062                    (variable-name (local-function-variable local-function)))
    4063            (unless (null (compiland-parent compiland))
    4064              (setf saved-vars
    4065                    (save-variables (intersection
    4066                                     (compiland-arg-vars (local-function-compiland local-function))
    4067                                     *visible-variables*))))
    4068 ;;            (emit 'var-ref (local-function-variable local-function) 'stack)
    4069            (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil))
    4070           (t
    4071            (dformat t "compile-local-function-call default case~%")
    4072            (let* ((g (if *compile-file-truename*
    4073                          (declare-local-function local-function)
    4074                          (declare-object (local-function-function local-function)))))
    4075              (emit 'getstatic *this-class* g +lisp-object+) ; Stack: template-function
    4076              (when *closure-variables*
    4077                (emit 'checkcast +lisp-ctf-class+)
    4078                (emit 'aload (compiland-closure-register compiland))
    4079                (emit-invokestatic +lisp-class+ "makeCompiledClosure"
    4080                                   (list +lisp-object+ +lisp-object-array+)
    4081                                   +lisp-object+)))))
    4082     (let ((must-clear-values nil))
    4083       (declare (type boolean must-clear-values))
    4084       (cond ((> (length args) call-registers-limit)
    4085              (emit-push-constant-int (length args))
    4086              (emit 'anewarray +lisp-object-class+)
    4087              (let ((i 0))
    4088                (dolist (arg args)
    4089                  (emit 'dup)
    4090                  (emit-push-constant-int i)
    4091                  (compile-form arg 'stack nil)
    4092                  (emit 'aastore) ; store value in array
    4093                  (unless must-clear-values
    4094                    (unless (single-valued-p arg)
    4095                      (setf must-clear-values t)))
    4096                  (incf i)))) ; array left on stack here
    4097             (t
    4098              (dolist (arg args)
    4099                (compile-form arg 'stack nil)
    4100                (unless must-clear-values
    4101                  (unless (single-valued-p arg)
    4102                    (setf must-clear-values t)))))) ; args left on stack here
    4103       (when must-clear-values
    4104         (emit-clear-values)))
    4105     (let* ((arg-count (length args))
    4106            (arg-types (if (<= arg-count call-registers-limit)
    4107                           (lisp-object-arg-types arg-count)
    4108                           (list +lisp-object-array+))) ;; FIXME
    4109            (result-type +lisp-object+))
    4110       (emit-invokevirtual +lisp-object-class+ "execute" arg-types result-type))
    4111     (fix-boxing representation nil)
    4112     (emit-move-from-stack target representation)
    4113     (when saved-vars
    4114       (restore-variables saved-vars)))
    4115   t)
    4116 
    4117 ;; Note that /= is not transitive, so we don't handle it here.
    4118 (defknown p2-numeric-comparison (t t t) t)
    4119 (defun p2-numeric-comparison (form target representation)
    4120   (aver (or (null representation) (eq representation :boolean)))
    4121   (let ((op (car form))
    4122         (args (%cdr form)))
    4123     (case (length args)
    4124       (2
    4125        (let* ((arg1 (%car args))
    4126               (arg2 (%cadr args))
    4127               (type1 (derive-compiler-type arg1))
    4128               (type2 (derive-compiler-type arg2)))
    4129          (cond ((and (integerp arg1) (integerp arg2))
    4130                 (let ((result (funcall op arg1 arg2)))
    4131                   (if result
    4132                       (emit-push-true representation)
    4133                       (emit-push-false representation)))
    4134                 (emit-move-from-stack target representation)
    4135                 (return-from p2-numeric-comparison))
    4136                ((and (fixnum-type-p type1)
    4137                      (fixnum-type-p type2))
    4138                 (let ((LABEL1 (gensym))
    4139                       (LABEL2 (gensym)))
    4140                   (compile-form arg1 'stack :int)
    4141                   (compile-form arg2 'stack :int)
    4142                   (maybe-emit-clear-values arg1 arg2)
    4143                   (emit (case op
    4144                           (<  'if_icmpge)
    4145                           (<= 'if_icmpgt)
    4146                           (>  'if_icmple)
    4147                           (>= 'if_icmplt)
    4148                           (=  'if_icmpne))
    4149                         LABEL1)
    4150                   (emit-push-true representation)
    4151                   (emit 'goto LABEL2)
    4152                   (label LABEL1)
    4153                   (emit-push-false representation)
    4154                   (label LABEL2))
    4155                 (emit-move-from-stack target representation)
    4156                 (return-from p2-numeric-comparison))
    4157                ((and (java-long-type-p type1)
    4158                      (java-long-type-p type2))
    4159                 (let ((LABEL1 (gensym))
    4160                       (LABEL2 (gensym)))
    4161                   (compile-form arg1 'stack :long)
    4162                   (compile-form arg2 'stack :long)
    4163                   (maybe-emit-clear-values arg1 arg2)
    4164                   (emit 'lcmp)
    4165                   (emit (case op
    4166                           (<  'ifge)
    4167                           (<= 'ifgt)
    4168                           (>  'ifle)
    4169                           (>= 'iflt)
    4170                           (=  'ifne))
    4171                         LABEL1)
    4172                   (emit-push-true representation)
    4173                   (emit 'goto LABEL2)
    4174                   (label LABEL1)
    4175                   (emit-push-false representation)
    4176                   (label LABEL2))
    4177                 (emit-move-from-stack target representation)
    4178                 (return-from p2-numeric-comparison))
    4179                ((fixnump arg2)
    4180                 (compile-form arg1 'stack nil)
    4181                 (maybe-emit-clear-values arg1)
    4182                 (emit-push-constant-int arg2)
    4183                 (emit-invokevirtual +lisp-object-class+
    4184                                     (case op
    4185                                       (<  "isLessThan")
    4186                                       (<= "isLessThanOrEqualTo")
    4187                                       (>  "isGreaterThan")
    4188                                       (>= "isGreaterThanOrEqualTo")
    4189                                       (=  "isEqualTo"))
    4190                                     '("I")
    4191                                     "Z")
    4192                 ;; Java boolean on stack here
    4193                 (case representation
    4194                   (:boolean)
    4195                   (t
    4196                    (let ((LABEL1 (gensym))
    4197                          (LABEL2 (gensym)))
    4198                      (emit 'ifeq LABEL1)
    4199                      (emit-push-t)
    4200                      (emit 'goto LABEL2)
    4201                      (label LABEL1)
    4202                      (emit-push-nil)
    4203                      (label LABEL2))))
    4204                 (emit-move-from-stack target representation)
    4205                 (return-from p2-numeric-comparison)))))
    4206       (3
    4207        (when (dolist (arg args t)
    4208                (unless (fixnum-type-p (derive-compiler-type arg))
    4209                  (return nil)))
    4210          (let* ((arg1 (%car args))
    4211                 (arg2 (%cadr args))
    4212                 (arg3 (%caddr args))
    4213                 (test (case op
    4214                         (<  'if_icmpge)
    4215                         (<= 'if_icmpgt)
    4216                         (>  'if_icmple)
    4217                         (>= 'if_icmplt)
    4218                         (=  'if_icmpne)))
    4219                 (LABEL1 (gensym))
    4220                 (LABEL2 (gensym))
    4221                 ;; If we do both tests, we need to use the arg2 value twice,
    4222                 ;; so we store that value in a temporary register.
    4223                 (*register* *register*)
    4224                 (arg2-register
    4225                  (unless (and (or (node-constant-p arg2)
    4226                                   (var-ref-p arg2))
    4227                               (node-constant-p arg3))
    4228                    (allocate-register)))
    4229                 (arg3-register
    4230                  (unless (node-constant-p arg3) (allocate-register))))
    4231            (compile-form arg1 'stack :int)
    4232            (compile-form arg2 'stack :int)
    4233            (when arg2-register
    4234              (emit 'dup)
    4235              (emit 'istore arg2-register))
    4236            (cond (arg3-register
    4237                   (compile-form arg3 'stack :int)
    4238                   (emit 'istore arg3-register)
    4239                   (maybe-emit-clear-values arg1 arg2 arg3))
    4240                  (t
    4241                   (maybe-emit-clear-values arg1 arg2)))
    4242            ;; First test.
    4243            (emit test LABEL1)
    4244            ;; Second test.
    4245            (cond (arg2-register
    4246                   (emit 'iload arg2-register))
    4247                  (t
    4248                   (compile-form arg2 'stack :int)))
    4249            (cond (arg3-register
    4250                   (emit 'iload arg3-register))
    4251                  (t
    4252                   (compile-form arg3 'stack :int)))
    4253            (emit test LABEL1)
    4254            (emit-push-true representation)
    4255            (emit 'goto LABEL2)
    4256            (label LABEL1)
    4257            (emit-push-false representation)
    4258            (label LABEL2)
    4259            (emit-move-from-stack target representation)
    4260            (return-from p2-numeric-comparison))))))
    4261   ;; Still here?
    4262   (compile-function-call form target representation))
    4263 
    4264 (defparameter *p2-test-handlers* nil)
    4265 
    4266 (defun p2-test-handler (op)
    4267   (gethash1 op (the hash-table *p2-test-handlers*)))
    4268 
    4269 (defun initialize-p2-test-handlers ()
    4270   (let ((ht (make-hash-table :test 'eq)))
    4271     (dolist (pair '(
    4272 ;;                     (CHAR= p2-test-char=)
    4273                     (/=                 p2-test-/=)
    4274                     (<                  p2-test-numeric-comparison)
    4275                     (<=                 p2-test-numeric-comparison)
    4276                     (=                  p2-test-numeric-comparison)
    4277                     (>                  p2-test-numeric-comparison)
    4278                     (>=                 p2-test-numeric-comparison)
    4279                     (AND                p2-test-and)
    4280                     (ATOM               p2-test-atom)
    4281                     (BIT-VECTOR-P       p2-test-bit-vector-p)
    4282                     (CHAR=              p2-test-char=)
    4283                     (CHARACTERP         p2-test-characterp)
    4284                     (CLASSP             p2-test-classp)
    4285                     (CONSP              p2-test-consp)
    4286                     (CONSTANTP          p2-test-constantp)
    4287                     (ENDP               p2-test-endp)
    4288                     (EQ                 p2-test-eq)
    4289                     (NEQ                p2-test-neq)
    4290                     (EQL                p2-test-eql)
    4291                     (EQUAL              p2-test-equality)
    4292                     (EQUALP             p2-test-equality)
    4293                     (EVENP              p2-test-evenp)
    4294                     (FIXNUMP            p2-test-fixnump)
    4295                     (FLOATP             p2-test-floatp)
    4296                     (INTEGERP           p2-test-integerp)
    4297                     (LISTP              p2-test-listp)
    4298                     (MEMQ               p2-test-memq)
    4299                     (MEMQL              p2-test-memql)
    4300                     (MINUSP             p2-test-minusp)
    4301                     (NOT                p2-test-not/null)
    4302                     (NULL               p2-test-not/null)
    4303                     (NUMBERP            p2-test-numberp)
    4304                     (PACKAGEP           p2-test-packagep)
    4305                     (ODDP               p2-test-oddp)
    4306                     (PLUSP              p2-test-plusp)
    4307                     (RATIONALP          p2-test-rationalp)
    4308                     (REALP              p2-test-realp)
    4309                     (SIMPLE-TYPEP       p2-test-simple-typep)
    4310                     (SIMPLE-VECTOR-P    p2-test-simple-vector-p)
    4311                     (SPECIAL-OPERATOR-P p2-test-special-operator-p)
    4312                     (SPECIAL-VARIABLE-P p2-test-special-variable-p)
    4313                     (STRINGP            p2-test-stringp)
    4314                     (SYMBOLP            p2-test-symbolp)
    4315                     (VECTORP            p2-test-vectorp)
    4316                     (ZEROP              p2-test-zerop)
    4317                     ))
    4318       (setf (gethash (%car pair) ht) (%cadr pair)))
    4319     (setf *p2-test-handlers* ht)))
    4320 
    4321 (initialize-p2-test-handlers)
    4322 
    4323 (defknown p2-test-predicate (t t) t)
    4324 (defun p2-test-predicate (form java-predicate)
    4325   (when (check-arg-count form 1)
    4326     (let ((arg (%cadr form)))
    4327       (compile-form arg 'stack nil)
    4328       (maybe-emit-clear-values arg)
    4329       (emit-invokevirtual +lisp-object-class+ java-predicate nil "Z")
    4330       'ifeq)))
    4331 
    4332 (declaim (ftype (function (t t) t) p2-test-instanceof-predicate))
    4333 (defun p2-test-instanceof-predicate (form java-class)
    4334   (when (check-arg-count form 1)
    4335     (let ((arg (%cadr form)))
    4336       (compile-form arg 'stack nil)
    4337       (maybe-emit-clear-values arg)
    4338       (emit 'instanceof java-class)
    4339       'ifeq)))
    4340 
    4341 (defun p2-test-bit-vector-p (form)
    4342   (p2-test-instanceof-predicate form +lisp-abstract-bit-vector-class+))
    4343 
    4344 (defun p2-test-characterp (form)
    4345   (p2-test-instanceof-predicate form +lisp-character-class+))
    4346 
    4347 ;; constantp form &optional environment => generalized-boolean
    4348 (defun p2-test-constantp (form)
    4349   (when (= (length form) 2)
    4350     (let ((arg (%cadr form)))
    4351       (compile-form arg 'stack nil)
    4352       (maybe-emit-clear-values arg)
    4353       (emit-invokevirtual +lisp-object-class+ "constantp" nil "Z")
    4354       'ifeq)))
    4355 
    4356 (defun p2-test-endp (form)
    4357   (p2-test-predicate form "endp"))
    4358 
    4359 (defun p2-test-evenp (form)
    4360   (when (check-arg-count form 1)
    4361     (let ((arg (%cadr form)))
    4362       (cond ((fixnum-type-p (derive-compiler-type arg))
    4363              (compile-form arg 'stack :int)
    4364              (maybe-emit-clear-values arg)
    4365              (emit-push-constant-int 1)
    4366              (emit 'iand)
    4367              'ifne)
    4368             (t
    4369              (p2-test-predicate form "evenp"))))))
    4370 
    4371 (defun p2-test-oddp (form)
    4372   (when (check-arg-count form 1)
    4373     (let ((arg (%cadr form)))
    4374       (cond ((fixnum-type-p (derive-compiler-type arg))
    4375              (compile-form arg 'stack :int)
    4376              (maybe-emit-clear-values arg)
    4377              (emit-push-constant-int 1)
    4378              (emit 'iand)
    4379              'ifeq)
    4380             (t
    4381              (p2-test-predicate form "oddp"))))))
    4382 
    4383 (defun p2-test-floatp (form)
    4384   (p2-test-predicate form "floatp"))
    4385 
    4386 (defun p2-test-integerp (form)
    4387   (p2-test-predicate form "integerp"))
    4388 
    4389 (defun p2-test-listp (form)
    4390   (when (check-arg-count form 1)
    4391     (let* ((arg (%cadr form))
    4392            (arg-type (derive-compiler-type arg)))
    4393       (cond ((memq arg-type '(CONS LIST NULL))
    4394              (compile-form arg nil nil) ; for effect
    4395              (maybe-emit-clear-values arg)
    4396              :consequent)
    4397             ((neq arg-type t)
    4398              (compile-form arg nil nil) ; for effect
    4399              (maybe-emit-clear-values arg)
    4400              :alternate)
    4401             (t
    4402              (p2-test-predicate form "listp"))))))
    4403 
    4404 (defun p2-test-minusp (form)
    4405   (when (check-arg-count form 1)
    4406     (let ((arg (%cadr form)))
    4407       (cond ((fixnum-type-p (derive-compiler-type arg))
    4408              (compile-form arg 'stack :int)
    4409              (maybe-emit-clear-values arg)
    4410              'ifge)
    4411             (t
    4412              (p2-test-predicate form "minusp"))))))
    4413 
    4414 (defun p2-test-plusp (form)
    4415   (when (check-arg-count form 1)
    4416     (let ((arg (%cadr form)))
    4417       (cond ((fixnum-type-p (derive-compiler-type arg))
    4418              (compile-form arg 'stack :int)
    4419              (maybe-emit-clear-values arg)
    4420              'ifle)
    4421             (t
    4422              (p2-test-predicate form "plusp"))))))
    4423 
    4424 (defun p2-test-zerop (form)
    4425   (when (check-arg-count form 1)
    4426     (let ((arg (%cadr form)))
    4427       (cond ((fixnum-type-p (derive-compiler-type arg))
    4428              (compile-form arg 'stack :int)
    4429              (maybe-emit-clear-values arg)
    4430              'ifne)
    4431             (t
    4432              (p2-test-predicate form "zerop"))))))
    4433 
    4434 (defun p2-test-numberp (form)
    4435   (p2-test-predicate form "numberp"))
    4436 
    4437 (defun p2-test-packagep (form)
    4438   (p2-test-instanceof-predicate form +lisp-package-class+))
    4439 
    4440 (defun p2-test-rationalp (form)
    4441   (p2-test-predicate form "rationalp"))
    4442 
    4443 (defun p2-test-realp (form)
    4444   (p2-test-predicate form "realp"))
    4445 
    4446 (defun p2-test-special-operator-p (form)
    4447   (p2-test-predicate form "isSpecialOperator"))
    4448 
    4449 (defun p2-test-special-variable-p (form)
    4450   (p2-test-predicate form "isSpecialVariable"))
    4451 
    4452 (defun p2-test-classp (form)
    4453   (p2-test-instanceof-predicate form +lisp-class-class+))
    4454 
    4455 (defun p2-test-symbolp (form)
    4456   (p2-test-instanceof-predicate form +lisp-symbol-class+))
    4457 
    4458 (defun p2-test-consp (form)
    4459   (p2-test-instanceof-predicate form +lisp-cons-class+))
    4460 
    4461 (defun p2-test-atom (form)
    4462   (p2-test-instanceof-predicate form +lisp-cons-class+)
    4463   'ifne)
    4464 
    4465 (defun p2-test-fixnump (form)
    4466   (p2-test-instanceof-predicate form +lisp-fixnum-class+))
    4467 
    4468 (defun p2-test-stringp (form)
    4469   (p2-test-instanceof-predicate form +lisp-abstract-string-class+))
    4470 
    4471 (defun p2-test-vectorp (form)
    4472   (p2-test-instanceof-predicate form +lisp-abstract-vector-class+))
    4473 
    4474 (defun p2-test-simple-vector-p (form)
    4475   (p2-test-instanceof-predicate form +lisp-simple-vector-class+))
    4476 
    4477 (defknown compile-test-form (t) t)
    4478 (defun compile-test-form (test-form)
    4479   (when (consp test-form)
    4480     (let* ((op (%car test-form))
    4481            (handler (p2-test-handler op))
    4482            (result (and handler (funcall handler test-form))))
    4483       (when result
    4484         (return-from compile-test-form result))))
    4485   (cond ((eq test-form t)
    4486          :consequent)
    4487         ((null test-form)
    4488          :alternate)
    4489         ((eq (derive-compiler-type test-form) 'BOOLEAN)
    4490          (compile-form test-form 'stack :boolean)
    4491          (maybe-emit-clear-values test-form)
    4492          'ifeq)
    4493         (t
    4494          (compile-form test-form 'stack nil)
    4495          (maybe-emit-clear-values test-form)
    4496          (emit-push-nil)
    4497          'if_acmpeq)))
    4498 
    4499 (defun p2-test-not/null (form)
    4500   (when (check-arg-count form 1)
    4501     (let* ((arg (%cadr form))
    4502            (result (compile-test-form arg)))
    4503       (ecase result
    4504         ('if_acmpeq  'if_acmpne)
    4505         ('if_acmpne  'if_acmpeq)
    4506         ('ifeq       'ifne)
    4507         ('ifne       'ifeq)
    4508         ('iflt       'ifge)
    4509         ('ifge       'iflt)
    4510         ('ifgt       'ifle)
    4511         ('ifle       'ifgt)
    4512         ('if_icmpeq  'if_icmpne)
    4513         ('if_icmpne  'if_icmpeq)
    4514         ('if_icmplt  'if_icmpge)
    4515         ('if_icmpge  'if_icmplt)
    4516         ('if_icmpgt  'if_icmple)
    4517         ('if_icmple  'if_icmpgt)
    4518         (:alternate  :consequent)
    4519         (:consequent :alternate)))))
    4520 
    4521 (defun p2-test-char= (form)
    4522   (when (check-arg-count form 2)
    4523     (let* ((arg1 (%cadr form))
    4524            (arg2 (%caddr form)))
    4525       (compile-form arg1 'stack :char)
    4526       (compile-form arg2 'stack :char)
    4527       (maybe-emit-clear-values arg1 arg2)
    4528       'if_icmpne)))
    4529 
    4530 (defun p2-test-eq (form)
    4531   (when (check-arg-count form 2)
    4532     (let ((arg1 (%cadr form))
    4533           (arg2 (%caddr form)))
    4534       (compile-form arg1 'stack nil)
    4535       (compile-form arg2 'stack nil)
    4536       (maybe-emit-clear-values arg1 arg2)
    4537      'if_acmpne)))
    4538 
    4539 (defun p2-test-and (form)
    4540   (let ((args (cdr form)))
    4541     (case (length args)
    4542       (0
    4543        :consequent)
    4544       (1
    4545        (compile-test-form (%car args)))
    4546       (2
    4547        (compile-form form 'stack :boolean)
    4548        'ifeq)
    4549       (t
    4550        (compile-form form 'stack nil)
    4551        (maybe-emit-clear-values form)
    4552        (emit-push-nil)
    4553        'if_acmpeq))))
    4554 
    4555 (defun p2-test-neq (form)
    4556   (p2-test-eq form)
    4557   'if_acmpeq)
    4558 
    4559 (defun p2-test-eql (form)
    4560   (when (check-arg-count form 2)
    4561     (let* ((arg1 (%cadr form))
    4562            (arg2 (%caddr form))
    4563            (type1 (derive-compiler-type arg1))
    4564            (type2 (derive-compiler-type arg2)))
    4565       (cond ((and (fixnum-type-p type1) (fixnum-type-p type2))
    4566              (compile-form arg1 'stack :int)
    4567              (compile-form arg2 'stack :int)
    4568              (maybe-emit-clear-values arg1 arg2)
    4569              'if_icmpne)
    4570             ((and (eq type1 'CHARACTER) (eq type2 'CHARACTER))
    4571              (compile-form arg1 'stack :char)
    4572              (compile-form arg2 'stack :char)
    4573              (maybe-emit-clear-values arg1 arg2)
    4574              'if_icmpne)
    4575             ((eq type2 'CHARACTER)
    4576              (compile-form arg1 'stack nil)
    4577              (compile-form arg2 'stack :char)
    4578              (maybe-emit-clear-values arg1 arg2)
    4579              (emit-invokevirtual +lisp-object-class+ "eql" '("C") "Z")
    4580              'ifeq)
    4581             ((eq type1 'CHARACTER)
    4582              (compile-form arg1 'stack :char)
    4583              (compile-form arg2 'stack nil)
    4584              (maybe-emit-clear-values arg1 arg2)
    4585              (emit 'swap)
    4586              (emit-invokevirtual +lisp-object-class+ "eql" '("C") "Z")
    4587              'ifeq)
    4588             ((fixnum-type-p type2)
    4589              (compile-form arg1 'stack nil)
    4590              (compile-form arg2 'stack :int)
    4591              (maybe-emit-clear-values arg1 arg2)
    4592              (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z")
    4593              'ifeq)
    4594             ((fixnum-type-p type1)
    4595              (compile-form arg1 'stack :int)
    4596              (compile-form arg2 'stack nil)
    4597              (maybe-emit-clear-values arg1 arg2)
    4598              (emit 'swap)
    4599              (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z")
    4600              'ifeq)
    4601             (t
    4602              (compile-form arg1 'stack nil)
    4603              (compile-form arg2 'stack nil)
    4604              (maybe-emit-clear-values arg1 arg2)
    4605              (emit-invokevirtual +lisp-object-class+ "eql"
    4606                                  (lisp-object-arg-types 1) "Z")
    4607              'ifeq)))))
    4608 
    4609 (defun p2-test-equality (form)
    4610 ;;   (format t "p2-test-equality ~S~%" (%car form))
    4611   (when (check-arg-count form 2)
    4612     (let* ((op (%car form))
    4613            (translated-op (ecase op
    4614 ;;                             (EQL    "eql")
    4615                             (EQUAL  "equal")
    4616                             (EQUALP "equalp")))
    4617            (arg1 (%cadr form))
    4618            (arg2 (%caddr form)))
    4619       (cond ((fixnum-type-p (derive-compiler-type arg2))
    4620              (compile-form arg1 'stack nil)
    4621              (compile-form arg2 'stack :int)
    4622              (maybe-emit-clear-values arg1 arg2)
    4623              (emit-invokevirtual +lisp-object-class+
    4624                                  translated-op
    4625                                  '("I") "Z"))
    4626             (t
    4627              (compile-form arg1 'stack nil)
    4628              (compile-form arg2 'stack nil)
    4629              (maybe-emit-clear-values arg1 arg2)
    4630              (emit-invokevirtual +lisp-object-class+
    4631                                  translated-op
    4632                                  (lisp-object-arg-types 1) "Z")))
    4633       'ifeq)))
    4634 
    4635 (defun p2-test-simple-typep (form)
    4636   (when (check-arg-count form 2)
    4637     (let ((arg1 (%cadr form))
    4638           (arg2 (%caddr form)))
    4639       (compile-form arg1 'stack nil)
    4640       (compile-form arg2 'stack nil)
    4641       (maybe-emit-clear-values arg1 arg2)
    4642       (emit-invokevirtual +lisp-object-class+ "typep"
    4643                           (lisp-object-arg-types 1) +lisp-object+)
    4644       (emit-push-nil)
    4645       'if_acmpeq)))
    4646 
    4647 (defun p2-test-memq (form)
    4648   (when (check-arg-count form 2)
    4649     (let ((arg1 (%cadr form))
    4650           (arg2 (%caddr form)))
    4651       (compile-form arg1 'stack nil)
    4652       (compile-form arg2 'stack nil)
    4653       (maybe-emit-clear-values arg1 arg2)
    4654       (emit-invokestatic +lisp-class+ "memq"
    4655                          (lisp-object-arg-types 2) "Z")
    4656       'ifeq)))
    4657 
    4658 (defun p2-test-memql (form)
    4659   (when (check-arg-count form 2)
    4660     (let ((arg1 (%cadr form))
    4661           (arg2 (%caddr form)))
    4662       (compile-form arg1 'stack nil)
    4663       (compile-form arg2 'stack nil)
    4664       (maybe-emit-clear-values arg1 arg2)
    4665       (emit-invokestatic +lisp-class+ "memql"
    4666                          (lisp-object-arg-types 2) "Z")
    4667       'ifeq)))
    4668 
    4669 (defun p2-test-/= (form)
    4670   (when (= (length form) 3)
    4671     (let* ((arg1 (%cadr form))
    4672            (arg2 (%caddr form))
    4673            (type1 (derive-compiler-type arg1))
    4674            (type2 (derive-compiler-type arg2)))
    4675       (cond ((and (numberp arg1) (numberp arg2))
    4676              (if (/= arg1 arg2) :consequent :alternate))
    4677             ((and (fixnum-type-p type1)
    4678                   (fixnum-type-p type2))
    4679              (compile-form arg1 'stack :int)
    4680              (compile-form arg2 'stack :int)
    4681              (maybe-emit-clear-values arg1 arg2)
    4682              'if_icmpeq)
    4683             ((fixnum-type-p type2)
    4684              (compile-form arg1 'stack nil)
    4685              (compile-form arg2 'stack :int)
    4686              (maybe-emit-clear-values arg1 arg2)
    4687              (emit-invokevirtual +lisp-object-class+ "isNotEqualTo" '("I") "Z")
    4688              'ifeq)
    4689             ((fixnum-type-p type1)
    4690              ;; FIXME Compile the args in reverse order and avoid the swap if
    4691              ;; either arg is a fixnum or a lexical variable.
    4692              (compile-form arg1 'stack :int)
    4693              (compile-form arg2 'stack nil)
    4694              (maybe-emit-clear-values arg1 arg2)
    4695              (emit 'swap)
    4696              (emit-invokevirtual +lisp-object-class+ "isNotEqualTo" '("I") "Z")
    4697              'ifeq)
    4698             (t
    4699              (compile-form arg1 'stack nil)
    4700              (compile-form arg2 'stack nil)
    4701              (maybe-emit-clear-values arg1 arg2)
    4702              (emit-invokevirtual +lisp-object-class+ "isNotEqualTo"
    4703                                  (lisp-object-arg-types 1) "Z")
    4704              'ifeq)))))
    4705 
    4706 (defun p2-test-numeric-comparison (form)
    4707   (when (check-min-args form 1)
    4708     (when (= (length form) 3)
    4709       (let* ((op (%car form))
    4710              (args (%cdr form))
    4711              (arg1 (%car args))
    4712              (arg2 (%cadr args))
    4713              (type1 (derive-compiler-type arg1))
    4714              (type2 (derive-compiler-type arg2)))
    4715         (cond ((and (fixnump arg1) (fixnump arg2))
    4716                (if (funcall op arg1 arg2) :consequent :alternate))
    4717               ((and (fixnum-type-p type1) (fixnum-type-p type2))
    4718                (compile-form arg1 'stack :int)
    4719                (compile-form arg2 'stack :int)
    4720                (maybe-emit-clear-values arg1 arg2)
    4721                (ecase op
    4722                  (<  'if_icmpge)
    4723                  (<= 'if_icmpgt)
    4724                  (>  'if_icmple)
    4725                  (>= 'if_icmplt)
    4726                  (=  'if_icmpne)))
    4727               ((and (java-long-type-p type1) (java-long-type-p type2))
    4728                (compile-form arg1 'stack :long)
    4729                (compile-form arg2 'stack :long)
    4730                (maybe-emit-clear-values arg1 arg2)
    4731                (emit 'lcmp)
    4732                (ecase op
    4733                  (<  'ifge)
    4734                  (<= 'ifgt)
    4735                  (>  'ifle)
    4736                  (>= 'iflt)
    4737                  (=  'ifne)))
    4738               ((fixnum-type-p type2)
    4739                (compile-form arg1 'stack nil)
    4740                (compile-form arg2 'stack :int)
    4741                (maybe-emit-clear-values arg1 arg2)
    4742                (emit-invokevirtual +lisp-object-class+
    4743                                    (ecase op
    4744                                      (<  "isLessThan")
    4745                                      (<= "isLessThanOrEqualTo")
    4746                                      (>  "isGreaterThan")
    4747                                      (>= "isGreaterThanOrEqualTo")
    4748                                      (=  "isEqualTo"))
    4749                                    '("I") "Z")
    4750                'ifeq)
    4751               ((fixnum-type-p type1)
    4752                ;; FIXME We can compile the args in reverse order and avoid
    4753                ;; the swap if either arg is a fixnum or a lexical variable.
    4754                (compile-form arg1 'stack :int)
    4755                (compile-form arg2 'stack nil)
    4756                (maybe-emit-clear-values arg1 arg2)
    4757                (emit 'swap)
    4758                (emit-invokevirtual +lisp-object-class+
    4759                                    (ecase op
    4760                                      (<  "isGreaterThan")
    4761                                      (<= "isGreaterThanOrEqualTo")
    4762                                      (>  "isLessThan")
    4763                                      (>= "isLessThanOrEqualTo")
    4764                                      (=  "isEqualTo"))
    4765                                    '("I") "Z")
    4766                'ifeq)
    4767               (t
    4768                (compile-form arg1 'stack nil)
    4769                (compile-form arg2 'stack nil)
    4770                (maybe-emit-clear-values arg1 arg2)
    4771                (emit-invokevirtual +lisp-object-class+
    4772                                    (ecase op
    4773                                      (<  "isLessThan")
    4774                                      (<= "isLessThanOrEqualTo")
    4775                                      (>  "isGreaterThan")
    4776                                      (>= "isGreaterThanOrEqualTo")
    4777                                      (=  "isEqualTo"))
    4778                                    (lisp-object-arg-types 1) "Z")
    4779                'ifeq))))))
    4780 
    4781 (defknown p2-if-or (t t t) t)
    4782 (defun p2-if-or (form target representation)
    4783   (let* ((test (second form))
    4784          (consequent (third form))
    4785          (alternate (fourth form))
    4786          (LABEL1 (gensym))
    4787          (LABEL2 (gensym)))
    4788     (aver (and (consp test) (eq (car test) 'OR)))
    4789     (let* ((args (cdr test)))
    4790       (case (length args)
    4791         (0
    4792          (compile-form alternate target representation))
    4793         (1
    4794          (p2-if (list 'IF (%car args) consequent alternate) target representation))
    4795         (t
    4796          (dolist (arg args)
    4797            (cond ((and (consp arg) (eq (first arg) 'EQ))
    4798                   ;; ERROR CHECKING HERE!
    4799                   (let ((arg1 (second arg))
    4800                         (arg2 (third arg)))
    4801                     (compile-form arg1 'stack nil)
    4802                     (compile-form arg2 'stack nil)
    4803                     (maybe-emit-clear-values arg1 arg2)
    4804                     (emit 'if_acmpeq LABEL1)))
    4805                  ((eq (derive-compiler-type arg) 'BOOLEAN)
    4806                   (compile-form arg 'stack :boolean)
    4807                   (maybe-emit-clear-values arg)
    4808                   (emit 'ifne LABEL1))
    4809                  (t
    4810                   (compile-form arg 'stack nil)
    4811                   (maybe-emit-clear-values arg)
    4812                   (emit-push-nil)
    4813                   (emit 'if_acmpne LABEL1))))
    4814          (compile-form alternate target representation)
    4815          (emit 'goto LABEL2)
    4816          (label LABEL1)
    4817          (compile-form consequent target representation)
    4818          (label LABEL2))))))
    4819 
    4820 (defknown p2-if-and (t t t) t)
    4821 (defun p2-if-and (form target representation)
    4822   (let* ((test (second form))
    4823          (consequent (third form))
    4824          (alternate (fourth form))
    4825          (LABEL1 (gensym))
    4826          (LABEL2 (gensym)))
    4827     (aver (and (consp test) (eq (car test) 'AND)))
    4828     (let* ((args (cdr test)))
    4829       (case (length args)
    4830         (0
    4831          (compile-form consequent target representation))
    4832         (1
    4833          (p2-if (list 'IF (%car args) consequent alternate) target representation))
    4834         (t
    4835          (dolist (arg args)
    4836 ;;            (let ((type (derive-compiler-type arg)))
    4837 ;;              (cond
    4838 ;;               ((eq type 'BOOLEAN)
    4839                     (compile-form arg 'stack :boolean)
    4840                     (maybe-emit-clear-values arg)
    4841                     (emit 'ifeq LABEL1)
    4842 ;;                )
    4843 ;;                    (t
    4844 ;;                     (compile-form arg 'stack nil)
    4845 ;;                     (maybe-emit-clear-values arg)
    4846 ;;                     (emit-push-nil)
    4847 ;;                     (emit 'if_acmpeq LABEL1))
    4848 ;;                    )
    4849 ;;              )
    4850            )
    4851          (compile-form consequent target representation)
    4852          (emit 'goto LABEL2)
    4853          (label LABEL1)
    4854          (compile-form alternate target representation)
    4855          (label LABEL2))))))
    4856 
    4857 (defknown p2-if-not-and (t t t) t)
    4858 (defun p2-if-not-and (form target representation)
    4859 ;;   (format t "p2-if-not-and~%")
    4860 ;;   (aver (eq (first form) 'IF))
    4861 ;;   (aver (consp (second form)))
    4862 ;;   (aver (memq (first (second form)) '(NOT NULL)))
    4863 ;;   (aver (eq (first (second (second form))) 'AND))
    4864   (let* ((inverted-test (second (second form)))
    4865          (consequent (third form))
    4866          (alternate (fourth form))
    4867          (LABEL1 (gensym))
    4868          (LABEL2 (gensym)))
    4869 ;;     (aver (and (consp inverted-test) (eq (car inverted-test) 'AND)))
    4870     (let* ((args (cdr inverted-test)))
    4871       (case (length args)
    4872         (0
    4873          (compile-form alternate target representation))
    4874         (1
    4875          (p2-if (list 'IF (%car args) alternate consequent) target representation))
    4876         (t
    4877          (dolist (arg args)
    4878            (let ((type (derive-compiler-type arg)))
    4879              (cond ((eq type 'BOOLEAN)
    4880                     (compile-form arg 'stack :boolean)
    4881                     (maybe-emit-clear-values arg)
    4882                     (emit 'ifeq LABEL1))
    4883                    (t
    4884                     (compile-form arg 'stack nil)
    4885                     (maybe-emit-clear-values arg)
    4886                     (emit-push-nil)
    4887                     (emit 'if_acmpeq LABEL1)))))
    4888          (compile-form alternate target representation)
    4889          (emit 'goto LABEL2)
    4890          (label LABEL1)
    4891          (compile-form consequent target representation)
    4892          (label LABEL2))))))
    4893 
    4894 (defknown p2-if (t t t) t)
    4895 (defun p2-if (form target representation)
    4896   (let* ((test (second form))
    4897          (consequent (third form))
    4898          (alternate (fourth form))
    4899          (LABEL1 (gensym))
    4900          (LABEL2 (gensym)))
    4901     (cond ((eq test t)
    4902            (compile-form consequent target representation))
    4903           ((null test)
    4904            (compile-form alternate target representation))
    4905           ((numberp test)
    4906            (compile-form consequent target representation))
    4907           ((equal (derive-compiler-type test) +true-type+)
    4908            (compile-form test nil nil) ; for effect
    4909            (maybe-emit-clear-values test)
    4910            (compile-form consequent target representation))
    4911           ((and (consp test) (eq (car test) 'OR))
    4912            (p2-if-or form target representation))
    4913           ((and (consp test) (eq (car test) 'AND))
    4914            (p2-if-and form target representation))
    4915           ((and (consp test)
    4916                 (memq (first test) '(NOT NULL))
    4917                 (consp (second test))
    4918                 (eq (first (second test)) 'AND))
    4919            (p2-if-not-and form target representation))
    4920           (t
    4921            (let ((result (compile-test-form test)))
    4922              (case result
    4923                (:consequent
    4924                 (compile-form consequent target representation))
    4925                (:alternate
    4926                 (compile-form alternate target representation))
    4927                (t
    4928                 (emit result LABEL1)
    4929                 (compile-form consequent target representation)
    4930                 (emit 'goto LABEL2)
    4931                 (label LABEL1)
    4932                 (compile-form alternate target representation)
    4933                 (label LABEL2))))))))
    4934 
    4935 (defun compile-multiple-value-list (form target representation)
    4936   (emit-clear-values)
    4937   (compile-form (second form) 'stack nil)
    4938   (emit-invokestatic +lisp-class+ "multipleValueList"
    4939                      (lisp-object-arg-types 1) +lisp-object+)
    4940   (fix-boxing representation nil)
    4941   (emit-move-from-stack target))
    4942 
    4943 (defun compile-multiple-value-prog1 (form target representation)
    4944   (let ((first-subform (cadr form))
    4945         (subforms (cddr form))
    4946         (result-register (allocate-register))
    4947         (values-register (allocate-register)))
    4948     ;; Make sure there are no leftover values from previous calls.
    4949     (emit-clear-values)
    4950     (compile-form first-subform result-register nil)
    4951     ;; Save multiple values returned by first subform.
    4952     (emit-push-current-thread)
    4953     (emit 'getfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;")
    4954     (emit 'astore values-register)
    4955     (dolist (subform subforms)
    4956       (compile-form subform nil nil))
    4957     ;; Restore multiple values returned by first subform.
    4958     (emit-push-current-thread)
    4959     (emit 'aload values-register)
    4960     (emit 'putfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;")
    4961     ;; Result.
    4962     (emit 'aload result-register)
    4963     (fix-boxing representation nil)
    4964     (emit-move-from-stack target)))
    4965 
    4966 (defun compile-multiple-value-call (form target representation)
    4967   ;; FIXME What if we're called with a non-NIL representation?
    4968   (aver (null representation))
    4969   (case (length form)
    4970     (1
    4971      (error "Wrong number of arguments for MULTIPLE-VALUE-CALL."))
    4972     (2
    4973      (compile-form (second form) 'stack nil)
    4974      (emit-invokestatic +lisp-class+ "coerceToFunction"
    4975                         (lisp-object-arg-types 1) +lisp-object+)
    4976      (emit-invokevirtual +lisp-object-class+ "execute" nil +lisp-object+))
    4977     (3
    4978      (let* ((*register* *register*)
    4979             (function-register (allocate-register)))
    4980        (compile-form (second form) function-register nil)
    4981        (compile-form (third form) 'stack nil)
    4982        (emit 'aload function-register)
    4983        (emit-push-current-thread)
    4984        (emit-invokestatic +lisp-class+ "multipleValueCall1"
    4985                           (list +lisp-object+ +lisp-object+ +lisp-thread+)
    4986                           +lisp-object+)))
    4987     (t
    4988      ;; The general case.
    4989      (let* ((*register* *register*)
    4990             (function-register (allocate-register))
    4991             (values-register (allocate-register)))
    4992        (compile-form (second form) 'stack nil)
    4993        (emit-invokestatic +lisp-class+ "coerceToFunction"
    4994                           (lisp-object-arg-types 1) +lisp-object+)
    4995        (emit-move-from-stack function-register)
    4996        (emit 'aconst_null)
    4997        (emit 'astore values-register)
    4998        (dolist (values-form (cddr form))
    4999          (compile-form values-form 'stack nil)
    5000          (emit-push-current-thread)
    5001          (emit 'swap)
    5002          (emit 'aload values-register)
    5003          (emit-invokevirtual +lisp-thread-class+ "accumulateValues"
    5004                              (list +lisp-object+ +lisp-object-array+)
    5005                              +lisp-object-array+)
    5006          (emit 'astore values-register)
    5007          (maybe-emit-clear-values values-form))
    5008        (emit 'aload function-register)
    5009        (emit 'aload values-register)
    5010        (emit-invokevirtual +lisp-object-class+ "dispatch"
    5011                            (list +lisp-object-array+) +lisp-object+))))
    5012   (fix-boxing representation nil)
    5013   (emit-move-from-stack target))
    5014 
    5015 (defknown unused-variable (t) t)
    5016 (defun unused-variable (variable)
    5017   (unless (or (variable-ignore-p variable)
    5018               (variable-ignorable-p variable))
    5019     (compiler-style-warn "The variable ~S is defined but never used."
    5020                          (variable-name variable))))
    5021 
    5022 (defknown check-for-unused-variables (list) t)
    5023 (defun check-for-unused-variables (list)
    5024   (dolist (variable list)
    5025     (when (and (not (variable-special-p variable))
    5026                (zerop (variable-reads variable))
    5027                (zerop (variable-writes variable)))
    5028       (unused-variable variable))))
    5029 
    5030 ;; Generates code to bind variable to value at top of runtime stack.
    5031 (declaim (ftype (function (t) t) compile-binding))
    5032 (defun compile-binding (variable)
    5033   (cond ((variable-register variable)
    5034          (emit 'astore (variable-register variable)))
    5035         ((variable-special-p variable)
    5036          (emit-push-current-thread)
    5037          (emit 'swap)
    5038          (emit 'getstatic *this-class*
    5039                (declare-symbol (variable-name variable)) +lisp-symbol+)
    5040          (emit 'swap)
    5041          (emit-invokevirtual +lisp-thread-class+ "bindSpecial"
    5042                              (list +lisp-symbol+ +lisp-object+) nil))
    5043         ((variable-closure-index variable)
    5044          (emit 'aload (compiland-closure-register *current-compiland*))
    5045          (emit 'swap) ; array value
    5046          (emit-push-constant-int (variable-closure-index variable))
    5047          (emit 'swap) ; array index value
    5048          (emit 'aastore))
    5049         (t
    5050          (aver nil))))
    5051 
    5052 (defknown compile-progn-body (t t &optional t) t)
    5053 (defun compile-progn-body (body target &optional representation)
    5054   (cond ((null body)
    5055          (when target
    5056            (emit-push-nil)
    5057            (emit-move-from-stack target)))
    5058         (t
    5059          (let ((clear-values nil)
    5060                (tail body))
    5061            (loop
    5062              (let ((form (car tail)))
    5063                (cond ((null (cdr tail))
    5064                       ;; Last form.
    5065                       (when clear-values
    5066                         (emit-clear-values))
    5067                       (compile-form form target representation)
    5068                       (return))
    5069                      (t
    5070                       ;; Not the last form.
    5071                       (compile-form form nil nil)
    5072                       (unless clear-values
    5073                         (unless (single-valued-p form)
    5074                           (setq clear-values t)))))
    5075                (setq tail (cdr tail)))))))
    5076   t)
    5077 
    5078 (defun p2-m-v-b-node (block target)
    5079   (let* ((*blocks* (cons block *blocks*))
    5080          (*register* *register*)
    5081          (form (block-form block))
    5082          (*visible-variables* *visible-variables*)
    5083          (vars (second form))
    5084          (bind-special-p nil)
    5085          (variables (block-vars block)))
    5086     (dolist (variable variables)
    5087       (let ((special-p (variable-special-p variable)))
    5088         (cond (special-p
    5089                (setf bind-special-p t))
    5090               (t
    5091                (unless (variable-closure-index variable)
    5092                  (setf (variable-register variable) (allocate-register)))))))
    5093     ;; If we're going to bind any special variables...
    5094     (when bind-special-p
    5095       (dformat t "p2-m-v-b-node lastSpecialBinding~%")
    5096       ;; Save current dynamic environment.
    5097       (setf (block-environment-register block) (allocate-register))
    5098       (emit-push-current-thread)
    5099       (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+)
    5100       (emit 'astore (block-environment-register block)))
    5101     ;; Make sure there are no leftover values from previous calls.
    5102     (emit-clear-values)
    5103     ;; Bind the variables.
    5104     (aver (= (length vars) (length variables)))
    5105     (cond ((= (length vars) 1)
    5106            (compile-form (third form) 'stack nil)
    5107            (maybe-emit-clear-values (third form))
    5108            (compile-binding (car variables)))
    5109           (t
    5110            (let* ((*register* *register*)
    5111                   (result-register (allocate-register))
    5112                   (values-register (allocate-register))
    5113                   (LABEL1 (gensym))
    5114                   (LABEL2 (gensym)))
    5115              ;; Store primary value from values form in result register.
    5116              (compile-form (third form) result-register nil)
    5117              ;; Store values from values form in values register.
    5118              (emit-push-current-thread)
    5119              (emit 'getfield +lisp-thread-class+ "_values" "[Lorg/armedbear/lisp/LispObject;")
    5120              (emit-move-from-stack values-register)
    5121              ;; Did we get just one value?
    5122              (emit 'aload values-register)
    5123              (emit 'ifnull LABEL1)
    5124              ;; Reaching here, we have multiple values (or no values at all). We need
    5125              ;; the slow path if we have more variables than values.
    5126              (emit 'aload values-register)
    5127              (emit 'arraylength)
    5128              (emit 'bipush (length vars))
    5129              (emit 'if_icmplt LABEL1)
    5130              ;; Reaching here, we have enough values for all the variables. We can use
    5131              ;; the values we have. This is the fast path.
    5132              (emit 'aload values-register)
    5133              (emit 'goto LABEL2)
    5134              (label LABEL1)
    5135              (emit-push-current-thread)
    5136              (emit 'aload result-register)
    5137              (emit 'bipush (length vars))
    5138              (emit-invokevirtual +lisp-thread-class+ "getValues"
    5139                                  (list +lisp-object+ "I") +lisp-object-array+)
    5140              ;; Values array is now on the stack at runtime.
    5141              (label LABEL2)
    5142              (let ((index 0))
    5143                (dolist (variable variables)
    5144                  (when (< index (1- (length vars)))
    5145                    (emit 'dup))
    5146                  (emit 'bipush index)
    5147                  (incf index)
    5148                  (emit 'aaload)
    5149                  ;; Value is on the runtime stack at this point.
    5150                  (compile-binding variable)))
    5151              (maybe-emit-clear-values (third form)))))
    5152     ;; Make the variables visible for the body forms.
    5153     (dolist (variable variables)
    5154       (push variable *visible-variables*))
    5155     ;; Body.
    5156     (compile-progn-body (cdddr form) target)
    5157     (when bind-special-p
    5158       ;; Restore dynamic environment.
    5159       (emit 'aload *thread*)
    5160       (emit 'aload (block-environment-register block))
    5161       (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+))))
    5162 
    5163 (defun propagate-vars (block)
    5164   (let ((removed '()))
    5165     (dolist (variable (block-vars block))
    5166       (unless (or (variable-special-p variable)
    5167                   (variable-closure-index variable))
    5168         (when (eql (variable-writes variable) 0)
    5169           ;; There are no writes to the variable.
    5170           (let ((initform (variable-initform variable)))
    5171             (cond ((var-ref-p initform)
    5172                    (let ((source-var (var-ref-variable initform)))
    5173                      (cond ((null source-var)
    5174                             (aver (var-ref-constant-p initform))
    5175                             (let ((value (var-ref-constant-value initform)))
    5176                               (dolist (ref (variable-references variable))
    5177                                 (aver (eq (var-ref-variable ref) variable))
    5178                                 (setf (var-ref-variable ref) nil
    5179                                       (var-ref-constant-p ref) t
    5180                                       (var-ref-constant-value ref) value))))
    5181                            (t
    5182                             (unless (or (variable-special-p source-var)
    5183                                         (variable-used-non-locally-p source-var))
    5184                               (when (eql (variable-writes source-var) 0)
    5185                                 ;; We can eliminate the variable.
    5186                                 ;; FIXME This may no longer be true when we start tracking writes!
    5187                                 (aver (= (variable-reads variable) (length (variable-references variable))))
    5188                                 (dolist (ref (variable-references variable))
    5189                                   (aver (eq (var-ref-variable ref) variable))
    5190                                   (setf (var-ref-variable ref) source-var))
    5191                                 ;; Check for DOTIMES limit variable.
    5192                                 (when (get (variable-name variable) 'sys::dotimes-limit-variable-p)
    5193                                   (let* ((symbol (get (variable-name variable) 'sys::dotimes-index-variable-name))
    5194                                          (index-variable (find-variable symbol (block-vars block))))
    5195                                     (when index-variable
    5196                                       (setf (get (variable-name index-variable) 'sys::dotimes-limit-variable-name)
    5197                                             (variable-name source-var)))))
    5198                                 (push variable removed)))))))
    5199                   ((fixnump initform)
    5200                    (dolist (ref (variable-references variable))
    5201                      (aver (eq (var-ref-variable ref) variable))
    5202                      (setf (var-ref-variable ref) nil
    5203                            (var-ref-constant-p ref) t
    5204                            (var-ref-constant-value ref) initform))
    5205                    (push variable removed)))))))
    5206     (when removed
    5207       (dolist (variable removed)
    5208         (setf (block-vars block) (remove variable (block-vars block)))))))
    5209 
    5210 (defknown p2-let-bindings (t) t)
    5211 (defun p2-let-bindings (block)
    5212   (dolist (variable (block-vars block))
    5213     (unless (or (variable-special-p variable)
    5214                 (variable-closure-index variable)
    5215                 (zerop (variable-reads variable)))
    5216       (aver (null (variable-register variable)))
    5217       (setf (variable-register variable) t)))
    5218   (let ((must-clear-values nil))
    5219     (declare (type boolean must-clear-values))
    5220     ;; Evaluate each initform. If the variable being bound is special, allocate
    5221     ;; a temporary register for the result; LET bindings must be done in
    5222     ;; parallel, so we can't modify any specials until all the initforms have
    5223     ;; been evaluated. Note that we can't just push the values on the stack
    5224     ;; because we'll lose JVM stack consistency if there is a non-local
    5225     ;; transfer of control from one of the initforms.
    5226     (dolist (variable (block-vars block))
    5227       (let* ((initform (variable-initform variable))
    5228              (unused-p (and (not (variable-special-p variable))
    5229                             ;; If it's never read, we don't care about writes.
    5230                             (zerop (variable-reads variable)))))
    5231         (cond (unused-p
    5232                (compile-form initform nil nil)) ; for effect
    5233               (t
    5234                (cond (initform
    5235                       (when (eq (variable-register variable) t)
    5236                         (let ((declared-type (variable-declared-type variable)))
    5237                           (cond ((neq declared-type :none)
    5238                                  (cond ((fixnum-type-p declared-type)
    5239                                         (setf (variable-representation variable) :int))
    5240                                        ((java-long-type-p declared-type)
    5241                                         (setf (variable-representation variable) :long))))
    5242                                 ((zerop (variable-writes variable))
    5243                                  (let ((derived-type (derive-compiler-type initform)))
    5244                                    (setf (variable-derived-type variable) derived-type)
    5245                                    (cond ((fixnum-type-p derived-type)
    5246                                           (setf (variable-representation variable) :int))
    5247                                          ((java-long-type-p derived-type)
    5248                                           (setf (variable-representation variable) :long)))))
    5249                                 ((get (variable-name variable) 'sys::dotimes-index-variable-p)
    5250                                  ;; DOTIMES index variable.
    5251                                  (let* ((name (get (variable-name variable) 'sys::dotimes-limit-variable-name))
    5252                                         (limit-variable (and name
    5253                                                              (or (find-variable name (block-vars block))
    5254                                                                  (find-visible-variable name)))))
    5255                                    (when limit-variable
    5256                                      (let ((type (variable-derived-type limit-variable)))
    5257                                        (when (eq type :none)
    5258                                          (setf type (variable-declared-type limit-variable)))
    5259                                        (cond ((fixnum-type-p type)
    5260                                               (setf (variable-representation variable) :int
    5261 ;;                                                     (variable-derived-type variable) 'FIXNUM
    5262                                                     (variable-derived-type variable) type
    5263                                                     ))
    5264                                              ((java-long-type-p type)
    5265                                               (setf (variable-representation variable) :long
    5266 ;;                                                     (variable-derived-type variable) 'JAVA-LONG
    5267                                                     (variable-derived-type variable) type
    5268                                                     ))))))))))
    5269                       (compile-form initform 'stack (variable-representation variable))
    5270                       (unless must-clear-values
    5271                         (unless (single-valued-p initform)
    5272                           (setf must-clear-values t))))
    5273                      (t
    5274                       ;; No initform.
    5275                       (emit-push-nil)))
    5276                (when (eq (variable-register variable) t)
    5277                  ;; Now allocate the register.
    5278                  (setf (variable-register variable)
    5279                        (case (variable-representation variable)
    5280                          (:long
    5281                           ;; We need two registers for a long.
    5282                           (allocate-register-pair))
    5283                          (t
    5284                           (allocate-register)))))
    5285                (cond ((variable-special-p variable)
    5286                       (emit-move-from-stack (setf (variable-temp-register variable) (allocate-register))))
    5287                      ((eq (variable-representation variable) :int)
    5288                       (emit 'istore (variable-register variable)))
    5289                      ((eq (variable-representation variable) :long)
    5290                       (emit 'lstore (variable-register variable)))
    5291                      (t
    5292                       (compile-binding variable)))))))
    5293     (when must-clear-values
    5294       (emit-clear-values))
    5295     ;; Now that all the initforms have been evaluated, move the results from
    5296     ;; the temporary registers (if any) to their proper destinations.
    5297     (dolist (variable (block-vars block))
    5298       (when (variable-temp-register variable)
    5299         (aver (variable-special-p variable))
    5300         (emit 'aload (variable-temp-register variable))
    5301         (compile-binding variable))))
    5302   ;; Now make the variables visible.
    5303   (dolist (variable (block-vars block))
    5304     (push variable *visible-variables*))
    5305   t)
    5306 
    5307 (defknown p2-let*-bindings (t) t)
    5308 (defun p2-let*-bindings (block)
    5309   (let ((must-clear-values nil))
    5310     (declare (type boolean must-clear-values))
    5311     ;; Generate code to evaluate initforms and bind variables.
    5312     (dolist (variable (block-vars block))
    5313       (let* ((initform (variable-initform variable))
    5314              (unused-p (and (not (variable-special-p variable))
    5315                             (zerop (variable-reads variable))
    5316                             (zerop (variable-writes variable))))
    5317              (boundp nil))
    5318         (declare (type boolean unused-p boundp))
    5319         (macrolet ((update-must-clear-values ()
    5320                      `(unless must-clear-values
    5321                         (unless (single-valued-p initform)
    5322                           (setf must-clear-values t)))))
    5323           (cond ((and (variable-special-p variable)
    5324                       (eq initform (variable-name variable)))
    5325                  ;; The special case of binding a special to its current value.
    5326                  (emit-push-current-thread)
    5327                  (emit 'getstatic *this-class*
    5328                        (declare-symbol (variable-name variable)) +lisp-symbol+)
    5329                  (emit-invokevirtual +lisp-thread-class+
    5330                                      "bindSpecialToCurrentValue"
    5331                                      (list +lisp-symbol+)
    5332                                      nil)
    5333                  (setf boundp t))
    5334                 ((and (not (variable-special-p variable))
    5335                       (zerop (variable-reads variable)))
    5336                  ;; We don't have to bind it if we never read it.
    5337                  (compile-form initform nil nil) ; for effect
    5338                  (update-must-clear-values)
    5339                  (setf boundp t))
    5340                 ((null initform)
    5341                  (cond ((and (null (variable-closure-index variable))
    5342                              (not (variable-special-p variable))
    5343                              (eq (variable-declared-type variable) 'BOOLEAN))
    5344                         (setf (variable-representation variable) :boolean)
    5345                         (setf (variable-register variable) (allocate-register))
    5346                         (emit 'iconst_0)
    5347                         (emit 'istore (variable-register variable))
    5348                         (setf boundp t))
    5349                        (t
    5350                         (emit-push-nil))))
    5351                 (t
    5352                   (cond (unused-p
    5353                          (compile-form initform nil nil) ; for effect
    5354                          (update-must-clear-values)
    5355                          (setf boundp t))
    5356                         ((and (null (variable-closure-index variable))
    5357                               (not (variable-special-p variable)))
    5358                          (let ((declared-type (variable-declared-type variable)))
    5359                            (cond ((and (neq declared-type :none)
    5360                                        (fixnum-type-p declared-type))
    5361                                   (setf (variable-representation variable) :int)
    5362                                   (compile-form initform 'stack :int)
    5363                                   (update-must-clear-values)
    5364                                   (setf (variable-register variable) (allocate-register))
    5365                                   (emit 'istore (variable-register variable))
    5366                                   (setf boundp t))
    5367                                  ((and (neq declared-type :none)
    5368                                        (java-long-type-p declared-type))
    5369                                   (setf (variable-representation variable) :long)
    5370                                   (compile-form initform 'stack :long)
    5371                                   (update-must-clear-values)
    5372                                   (setf (variable-register variable)
    5373                                         ;; We need two registers for a long.
    5374                                         (allocate-register-pair))
    5375                                   (emit 'lstore (variable-register variable))
    5376                                   (setf boundp t))
    5377                                  ((and (neq declared-type :none)
    5378                                        (eq declared-type 'BOOLEAN))
    5379                                   (setf (variable-representation variable) :boolean)
    5380                                   (compile-form initform 'stack :boolean)
    5381                                   (update-must-clear-values)
    5382                                   (setf (variable-register variable) (allocate-register))
    5383                                   (emit 'istore (variable-register variable))
    5384                                   (setf boundp t))
    5385                                  ((eql (variable-writes variable) 0)
    5386                                   (let ((type (derive-compiler-type initform)))
    5387                                     (setf (variable-derived-type variable) type)
    5388                                     (cond ((fixnum-type-p type)
    5389                                            (setf (variable-representation variable) :int)
    5390                                            (setf (variable-register variable) (allocate-register))
    5391                                            (compile-form initform 'stack :int)
    5392                                            (update-must-clear-values)
    5393                                            (emit 'istore (variable-register variable))
    5394                                            (setf boundp t))
    5395                                           ((java-long-type-p type)
    5396                                            (setf (variable-representation variable) :long)
    5397                                            (setf (variable-register variable)
    5398                                                  ;; We need two registers for a long.
    5399                                                  (allocate-register-pair))
    5400                                            (compile-form initform 'stack :long)
    5401                                            (update-must-clear-values)
    5402                                            (emit 'lstore (variable-register variable))
    5403                                            (setf boundp t))
    5404                                           ((eq type 'CHARACTER)
    5405                                            (setf (variable-representation variable) :char)
    5406                                            (setf (variable-register variable) (allocate-register))
    5407                                            (compile-form initform 'stack :char)
    5408                                            (update-must-clear-values)
    5409                                            (emit 'istore (variable-register variable))
    5410                                            (setf boundp t))
    5411                                           (t
    5412                                            (compile-form initform 'stack nil)
    5413                                            (update-must-clear-values)))))
    5414                                  (t
    5415                                   (compile-form initform 'stack nil)
    5416                                   (update-must-clear-values)))))
    5417                         (t
    5418                          (compile-form initform 'stack nil)
    5419                          (update-must-clear-values))))))
    5420         (unless (or boundp (variable-special-p variable))
    5421           (unless (or (variable-closure-index variable) (variable-register variable))
    5422             (setf (variable-register variable) (allocate-register))))
    5423         (push variable *visible-variables*)
    5424         (unless boundp
    5425           (compile-binding variable))
    5426         (maybe-generate-type-check variable)))
    5427     (when must-clear-values
    5428       (emit-clear-values)))
    5429   t)
    5430 
    5431 (defun p2-let/let*-node (block target representation)
    5432   (let* ((*blocks* (cons block *blocks*))
    5433          (*register* *register*)
    5434          (form (block-form block))
    5435          (*visible-variables* *visible-variables*)
    5436          (specialp nil))
    5437     ;; Walk the variable list looking for special bindings and unused lexicals.
    5438     (dolist (variable (block-vars block))
    5439       (cond ((variable-special-p variable)
    5440              (setf specialp t))
    5441             ((zerop (variable-reads variable))
    5442              (unused-variable variable))))
    5443     ;; If there are any special bindings...
    5444     (when specialp
    5445       ;; We need to save current dynamic environment.
    5446       (setf (block-environment-register block) (allocate-register))
    5447       (emit-push-current-thread)
    5448       (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+)
    5449       (emit 'astore (block-environment-register block)))
    5450     (propagate-vars block)
    5451     (ecase (car form)
    5452       (LET
    5453        (p2-let-bindings block))
    5454       (LET*
    5455        (p2-let*-bindings block)))
    5456     ;; Make declarations of free specials visible.
    5457     (dolist (variable (block-free-specials block))
    5458       (push variable *visible-variables*))
    5459     ;; Body of LET/LET*.
    5460     (with-saved-compiler-policy
    5461       (process-optimization-declarations (cddr form))
    5462       (compile-progn-body (cddr form) target representation))
    5463     (when specialp
    5464       ;; Restore dynamic environment.
    5465       (emit 'aload *thread*)
    5466       (emit 'aload (block-environment-register block))
    5467       (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+))))
    5468 
    5469 (defun p2-locally (form target representation)
    5470   (with-saved-compiler-policy
    5471     (let ((body (cdr form)))
    5472       (process-optimization-declarations body)
    5473       (compile-progn-body body target representation))))
    5474 
    5475 (defknown find-tag (t) t)
    5476 (defun find-tag (name)
    5477   (dolist (tag *visible-tags*)
    5478     (when (eql name (tag-name tag))
    5479       (return tag))))
    5480 
    5481 (defknown p2-tagbody-node (t t) t)
    5482 (defun p2-tagbody-node (block target)
    5483   (let* ((*blocks* (cons block *blocks*))
    5484          (*visible-tags* *visible-tags*)
    5485          (*register* *register*)
    5486          (form (block-form block))
    5487          (body (cdr form))
    5488          (local-tags ())
    5489          (BEGIN-BLOCK (gensym))
    5490          (END-BLOCK (gensym))
    5491          (EXIT (gensym))
    5492          environment-register
    5493          (must-clear-values nil))
    5494     ;; Scan for tags.
    5495     (dolist (subform body)
    5496       (when (or (symbolp subform) (integerp subform))
    5497         (let* ((tag (make-tag :name subform :label (gensym) :block block)))
    5498           (push tag local-tags)
    5499           (push tag *visible-tags*))))
    5500     (when (block-non-local-go-p block)
    5501       (dformat t "p2-tagbody-node lastSpecialBinding~%")
    5502       (setf environment-register (allocate-register))
    5503       (emit-push-current-thread)
    5504       (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+)
    5505       (emit 'astore environment-register))
    5506     (label BEGIN-BLOCK)
    5507     (do* ((rest body (cdr rest))
    5508           (subform (car rest) (car rest)))
    5509          ((null rest))
    5510       (cond ((or (symbolp subform) (integerp subform))
    5511              (let ((tag (find-tag subform)))
    5512                (unless tag
    5513                  (error "COMPILE-TAGBODY: tag not found: ~S~%" subform))
    5514                (label (tag-label tag))))
    5515             (t
    5516              (compile-form subform nil nil)
    5517              (unless must-clear-values
    5518                (unless (single-valued-p subform)
    5519 ;;                  (let ((*print-structure* nil))
    5520 ;;                    (format t "not single-valued: ~S~%" subform))
    5521                  (setf must-clear-values t))))))
    5522     (label END-BLOCK)
    5523     (emit 'goto EXIT)
    5524     (when (block-non-local-go-p block)
    5525       ; We need a handler to catch non-local GOs.
    5526       (let* ((HANDLER (gensym))
    5527              (*register* *register*)
    5528              (go-register (allocate-register))
    5529              (tag-register (allocate-register)))
    5530         (label HANDLER)
    5531         ;; The Go object is on the runtime stack. Stack depth is 1.
    5532         (emit 'dup)
    5533         (emit 'astore go-register)
    5534         ;; Get the tag.
    5535         (emit 'checkcast +lisp-go-class+)
    5536         (emit 'getfield +lisp-go-class+ "tag" +lisp-object+) ; Stack depth is still 1.
    5537         (emit 'astore tag-register)
    5538         (dolist (tag local-tags)
    5539           (let ((NEXT (gensym)))
    5540             (emit 'aload tag-register)
    5541             (emit 'getstatic *this-class*
    5542                   (if *compile-file-truename*
    5543                       (declare-object-as-string (tag-label tag))
    5544                       (declare-object (tag-label tag)))
    5545                   +lisp-object+)
    5546             (emit 'if_acmpne NEXT) ;; Jump if not EQ.
    5547             ;; Restore dynamic environment.
    5548             (emit-push-current-thread)
    5549             (aver (fixnump environment-register))
    5550             (emit 'aload environment-register)
    5551             (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+)
    5552             (emit 'goto (tag-label tag))
    5553             (label NEXT)))
    5554         ;; Not found. Re-throw Go.
    5555         (emit 'aload go-register)
    5556         (emit 'athrow)
    5557         ;; Finally...
    5558         (push (make-handler :from BEGIN-BLOCK
    5559                             :to END-BLOCK
    5560                             :code HANDLER
    5561                             :catch-type (pool-class +lisp-go-class+))
    5562               *handlers*)))
    5563     (label EXIT)
    5564     (when must-clear-values
    5565       (emit-clear-values))
    5566     ;; TAGBODY returns NIL.
    5567     (when target
    5568       (emit-push-nil)
    5569       (emit-move-from-stack target))))
    5570 
    5571 (defknown p2-go (t t t) t)
    5572 (defun p2-go (form target representation)
    5573   ;; FIXME What if we're called with a non-NIL representation?
    5574   (declare (ignore representation))
    5575   (let* ((name (cadr form))
    5576          (tag (find-tag name)))
    5577     (unless tag
    5578       (error "p2-go: tag not found: ~S" name))
    5579     (when (eq (tag-compiland tag) *current-compiland*)
    5580       ;; Local case.
    5581       (let* ((tag-block (tag-block tag))
    5582              (register nil)
    5583              (protected
    5584               ;; Does the GO leave an enclosing CATCH or UNWIND-PROTECT?
    5585               (dolist (enclosing-block *blocks*)
    5586                 (when (eq enclosing-block tag-block)
    5587                   (return nil))
    5588                 (let ((block-name (block-name enclosing-block)))
    5589                   (when (or (equal block-name '(CATCH))
    5590                             (equal block-name '(UNWIND-PROTECT)))
    5591                     (return t))))))
    5592         (unless protected
    5593           (dolist (block *blocks*)
    5594             (if (eq block tag-block)
    5595                 (return)
    5596                 (setf register (or (block-environment-register block) register))))
    5597           (when register
    5598             ;; Restore dynamic environment.
    5599             (emit 'aload *thread*)
    5600             (emit 'aload register)
    5601             (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+))
    5602           (maybe-generate-interrupt-check)
    5603           (emit 'goto (tag-label tag))
    5604           (return-from p2-go))))
    5605     ;; Non-local GO.
    5606     (emit 'new +lisp-go-class+)
    5607     (emit 'dup)
    5608     (compile-form `',(tag-label tag) 'stack nil) ; Tag.
    5609     (emit-invokespecial-init +lisp-go-class+ (lisp-object-arg-types 1))
    5610     (emit 'athrow)
    5611     ;; Following code will not be reached, but is needed for JVM stack
    5612     ;; consistency.
    5613     (when target
    5614       (emit-push-nil)
    5615       (emit-move-from-stack target))))
    5616 
    5617 (defknown p2-atom (t t t) t)
    5618 (defun p2-atom (form target representation)
    5619   (aver (or (null representation) (eq representation :boolean)))
    5620   (unless (check-arg-count form 1)
    5621     (compile-function-call form target representation)
    5622     (return-from p2-atom))
    5623   (compile-form (cadr form) 'stack nil)
    5624   (maybe-emit-clear-values (cadr form))
    5625   (emit 'instanceof +lisp-cons-class+)
    5626   (let ((LABEL1 (gensym))
    5627         (LABEL2 (gensym)))
    5628     (emit 'ifeq LABEL1)
    5629     (case representation
    5630       (:boolean
    5631        (emit 'iconst_0))
    5632       (t
    5633        (emit-push-nil)))
    5634     (emit 'goto LABEL2)
    5635     (label LABEL1)
    5636     (case representation
    5637       (:boolean
    5638        (emit 'iconst_1))
    5639       (t
    5640        (emit-push-t)))
    5641     (label LABEL2)
    5642     (emit-move-from-stack target representation)))
    5643 
    5644 (defknown p2-instanceof-predicate (t t t t) t)
    5645 (defun p2-instanceof-predicate (form target representation java-class)
    5646   (unless (check-arg-count form 1)
    5647     (compile-function-call form target representation)
    5648     (return-from p2-instanceof-predicate))
    5649   (let ((arg (%cadr form)))
    5650     (cond ((null target)
    5651            (compile-form arg nil nil) ; for effect
    5652            (maybe-emit-clear-values arg))
    5653           (t
    5654            (compile-form arg 'stack nil)
    5655            (maybe-emit-clear-values arg)
    5656            (emit 'instanceof java-class)
    5657            (case representation
    5658              (:boolean)
    5659              (t
    5660               (let ((LABEL1 (gensym))
    5661                     (LABEL2 (gensym)))
    5662                 (emit 'ifeq LABEL1)
    5663                 (emit-push-t)
    5664                 (emit 'goto LABEL2)
    5665                 (label LABEL1)
    5666                 (emit-push-nil)
    5667                 (label LABEL2)
    5668                 (emit-move-from-stack target representation))))))))
    5669 
    5670 (defun p2-bit-vector-p (form target representation)
    5671   (p2-instanceof-predicate form target representation +lisp-abstract-bit-vector-class+))
    5672 
    5673 (defun p2-characterp (form target representation)
    5674   (p2-instanceof-predicate form target representation +lisp-character-class+))
    5675 
    5676 (defun p2-classp (form target representation)
    5677   (p2-instanceof-predicate form target representation +lisp-class-class+))
    5678 
    5679 (defun p2-consp (form target representation)
    5680   (p2-instanceof-predicate form target representation +lisp-cons-class+))
    5681 
    5682 (defun p2-fixnump (form target representation)
    5683   (p2-instanceof-predicate form target representation +lisp-fixnum-class+))
    5684 
    5685 (defun p2-packagep (form target representation)
    5686   (p2-instanceof-predicate form target representation +lisp-package-class+))
    5687 
    5688 (defun p2-readtablep (form target representation)
    5689   (p2-instanceof-predicate form target representation +lisp-readtable-class+))
    5690 
    5691 (defun p2-simple-vector-p (form target representation)
    5692   (p2-instanceof-predicate form target representation +lisp-simple-vector-class+))
    5693 
    5694 (defun p2-stringp (form target representation)
    5695   (p2-instanceof-predicate form target representation +lisp-abstract-string-class+))
    5696 
    5697 (defun p2-symbolp (form target representation)
    5698   (p2-instanceof-predicate form target representation +lisp-symbol-class+))
    5699 
    5700 (defun p2-vectorp (form target representation)
    5701   (p2-instanceof-predicate form target representation +lisp-abstract-vector-class+))
    5702 
    5703 (defun p2-coerce-to-function (form target representation)
    5704   (unless (check-arg-count form 1)
    5705     (compile-function-call form target representation)
    5706     (return-from p2-coerce-to-function))
    5707   (compile-form (%cadr form) 'stack nil)
    5708   (maybe-emit-clear-values (%cadr form))
    5709   (emit-invokestatic +lisp-class+ "coerceToFunction"
    5710                      (lisp-object-arg-types 1) +lisp-object+)
    5711   (emit-move-from-stack target))
    5712 
    5713 (defun p2-block-node (block target representation)
    5714   (unless (block-node-p block)
    5715     (sys::%format t "type-of block = ~S~%" (type-of block))
    5716     (aver (block-node-p block)))
    5717   (let* ((*blocks* (cons block *blocks*))
    5718          (*register* *register*))
    5719     (cond ((block-return-p block)
    5720            (setf (block-target block) target)
    5721            (dformat t "p2-block-node lastSpecialBinding~%")
    5722            (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*))
    5723            (cond ((some #'variable-special-p *all-variables*)
    5724                   ;; Save the current dynamic environment.
    5725                   (setf (block-environment-register block) (allocate-register))
    5726                   (emit-push-current-thread)
    5727                   (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+)
    5728                   (emit 'astore (block-environment-register block)))
    5729                  (t
    5730                   (dformat t "no specials~%")))
    5731            (setf (block-catch-tag block) (gensym))
    5732            (let* ((*register* *register*)
    5733                   (BEGIN-BLOCK (gensym))
    5734                   (END-BLOCK (gensym))
    5735                   (BLOCK-EXIT (block-exit block)))
    5736              (label BEGIN-BLOCK) ; Start of protected range.
    5737              ;; Implicit PROGN.
    5738              (compile-progn-body (cddr (block-form block)) target)
    5739              (label END-BLOCK) ; End of protected range.
    5740              (emit 'goto BLOCK-EXIT) ; Jump over handler (if any).
    5741              (when (block-non-local-return-p block)
    5742                ; We need a handler to catch non-local RETURNs.
    5743                (let ((HANDLER (gensym))
    5744                      (RETHROW (gensym)))
    5745                  (label HANDLER)
    5746                  ;; The Return object is on the runtime stack. Stack depth is 1.
    5747                  (emit 'dup) ; Stack depth is 2.
    5748                  (emit 'getfield +lisp-return-class+ "tag" +lisp-object+) ; Still 2.
    5749                  (compile-form `',(block-catch-tag block) 'stack nil) ; Tag. Stack depth is 3.
    5750                  ;; If it's not the tag we're looking for...
    5751                  (emit 'if_acmpne RETHROW) ; Stack depth is 1.
    5752                  (emit 'getfield +lisp-return-class+ "result" +lisp-object+)
    5753                  (emit-move-from-stack target) ; Stack depth is 0.
    5754                  (emit 'goto BLOCK-EXIT)
    5755                  (label RETHROW)
    5756                  ;; Not the tag we're looking for.
    5757                  (emit 'athrow)
    5758                  ;; Finally...
    5759                  (push (make-handler :from BEGIN-BLOCK
    5760                                      :to END-BLOCK
    5761                                      :code HANDLER
    5762                                      :catch-type (pool-class +lisp-return-class+))
    5763                        *handlers*)))
    5764              (label BLOCK-EXIT))
    5765            (when (block-environment-register block)
    5766              ;; We saved the dynamic environment above. Restore it now.
    5767              (emit 'aload *thread*)
    5768              (emit 'aload (block-environment-register block))
    5769              (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+))
    5770            (fix-boxing representation nil)
    5771            )
    5772           (t
    5773            ;; No explicit returns.
    5774            (compile-progn-body (cddr (block-form block)) target representation)))))
    5775 
    5776 (defknown p2-return-from (t t t) t)
    5777 (defun p2-return-from (form target representation)
    5778   ;; FIXME What if we're called with a non-NIL representation?
    5779   (declare (ignore representation))
    5780   (let* ((name (second form))
    5781          (result-form (third form))
    5782          (block (find-block name)))
    5783     (when (null block)
    5784       (error "No block named ~S is currently visible." name))
    5785     (let ((compiland *current-compiland*))
    5786       (when (eq (block-compiland block) compiland)
    5787         ;; Local case. Is the RETURN nested inside an UNWIND-PROTECT which is
    5788         ;; inside the block we're returning from?
    5789         (let ((protected
    5790                (dolist (enclosing-block *blocks*)
    5791                  (when (eq enclosing-block block)
    5792                    (return nil))
    5793                  (when (equal (block-name enclosing-block) '(UNWIND-PROTECT))
    5794                    (return t)))))
    5795           (unless protected
    5796             (unless (compiland-single-valued-p *current-compiland*)
    5797 ;;               (format t "compiland not single-valued: ~S~%"
    5798 ;;                       (compiland-name *current-compiland*))
    5799               (emit-clear-values))
    5800             (compile-form result-form (block-target block) nil)
    5801             (emit 'goto (block-exit block))
    5802             (return-from p2-return-from)))))
    5803     ;; Non-local RETURN.
    5804     (aver (block-non-local-return-p block))
    5805     (cond ((node-constant-p result-form)
    5806            (emit 'new +lisp-return-class+)
    5807            (emit 'dup)
    5808            (compile-form `',(block-catch-tag block) 'stack nil) ; Tag.
    5809            (emit-clear-values)
    5810            (compile-form result-form 'stack nil)) ; Result.
    5811           (t
    5812            (let* ((*register* *register*)
    5813                   (temp-register (allocate-register)))
    5814              (emit-clear-values)
    5815              (compile-form result-form temp-register nil) ; Result.
    5816              (emit 'new +lisp-return-class+)
    5817              (emit 'dup)
    5818              (compile-form `',(block-catch-tag block) 'stack nil) ; Tag.
    5819              (emit 'aload temp-register))))
    5820     (emit-invokespecial-init +lisp-return-class+ (lisp-object-arg-types 2))
    5821     (emit 'athrow)
    5822     ;; Following code will not be reached, but is needed for JVM stack
    5823     ;; consistency.
    5824     (when target
    5825       (emit-push-nil)
    5826       (emit-move-from-stack target))))
    5827 
    5828 (defun p2-car (form target representation)
    5829   (unless (check-arg-count form 1)
    5830     (compile-function-call form target representation)
    5831     (return-from p2-car))
    5832   (let ((arg (%cadr form)))
    5833     (cond ((and (null target) (< *safety* 3))
    5834            (compile-form arg target nil))
    5835           ((and (consp arg) (eq (%car arg) 'cdr) (= (length arg) 2))
    5836            (compile-form (second arg) 'stack nil)
    5837            (maybe-emit-clear-values (second arg))
    5838            (emit-invoke-method "cadr" target representation))
    5839           ((eq (derive-type arg) 'CONS)
    5840            (compile-form arg 'stack nil)
    5841            (emit 'checkcast +lisp-cons-class+)
    5842            (emit 'getfield +lisp-cons-class+ "car" +lisp-object+)
    5843            (fix-boxing representation nil)
    5844            (emit-move-from-stack target representation))
    5845           (t
    5846            (compile-form arg 'stack nil)
    5847            (maybe-emit-clear-values arg)
    5848            (emit-invoke-method "car" target representation)))))
    5849 
    5850 (defun p2-cdr (form target representation)
    5851   (unless (check-arg-count form 1)
    5852     (compile-function-call form target representation)
    5853     (return-from p2-cdr))
    5854   (let ((arg (%cadr form)))
    5855     (cond ((eq (derive-type arg) 'CONS)
    5856            (compile-form arg 'stack nil)
    5857            (emit 'checkcast +lisp-cons-class+)
    5858            (emit 'getfield +lisp-cons-class+ "cdr" +lisp-object+)
    5859            (fix-boxing representation nil)
    5860            (emit-move-from-stack target representation))
    5861           (t
    5862            (compile-form arg 'stack nil)
    5863            (maybe-emit-clear-values arg)
    5864            (emit-invoke-method "cdr" target representation)))))
    5865 
    5866 (defun p2-cons (form target representation)
    5867   (unless (check-arg-count form 2)
    5868     (compile-function-call form target representation)
    5869     (return-from p2-cons))
    5870   (emit 'new +lisp-cons-class+)
    5871   (emit 'dup)
    5872   (let* ((args (%cdr form))
    5873          (arg1 (%car args))
    5874          (arg2 (%cadr args)))
    5875     (compile-form arg1 'stack nil)
    5876     (compile-form arg2 'stack nil)
    5877     (maybe-emit-clear-values arg1 arg2))
    5878   (emit-invokespecial-init +lisp-cons-class+ (lisp-object-arg-types 2))
    5879   (emit-move-from-stack target))
    5880 
    5881 (defun compile-progn (form target representation)
    5882   (compile-progn-body (cdr form) target)
    5883   (fix-boxing representation nil))
    5884 
    5885 (defun p2-eval-when (form target representation)
    5886   (cond ((or (memq :execute (cadr form))
    5887              (memq 'eval (cadr form)))
    5888          (compile-progn-body (cddr form) target)
    5889          (fix-boxing representation nil))
    5890         (t
    5891          (emit-push-nil)
    5892          (emit-move-from-stack target))))
    5893 
    5894 (defun p2-load-time-value (form target representation)
    5895   (cond (*compile-file-truename*
    5896          (emit 'getstatic *this-class*
    5897                (declare-load-time-value (second form)) +lisp-object+)
    5898          (fix-boxing representation nil)
    5899          (emit-move-from-stack target representation))
    5900         (t
    5901          (compile-constant (eval (second form)) target representation))))
    5902 
    5903 (defun p2-progv (form target representation)
    5904   (let* ((symbols-form (cadr form))
    5905          (values-form (caddr form))
    5906          (*register* *register*)
    5907          (environment-register (allocate-register)))
    5908     (compile-form symbols-form 'stack nil)
    5909     (compile-form values-form 'stack nil)
    5910     (unless (and (single-valued-p symbols-form)
    5911                  (single-valued-p values-form))
    5912       (emit-clear-values))
    5913     (emit-push-current-thread)
    5914     (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+)
    5915     (emit 'astore environment-register)
    5916     ;; Compile call to Lisp.progvBindVars().
    5917     (emit 'aload *thread*)
    5918     (emit-invokestatic +lisp-class+ "progvBindVars"
    5919                        (list +lisp-object+ +lisp-object+ +lisp-thread+) nil)
    5920     ;; Implicit PROGN.
    5921     (compile-progn-body (cdddr form) target)
    5922     ;; Restore dynamic environment.
    5923     (emit 'aload *thread*)
    5924     (emit 'aload environment-register)
    5925     (emit 'putfield +lisp-thread-class+ "lastSpecialBinding" +lisp-special-binding+)
    5926     (fix-boxing representation nil)))
    5927 
    5928 (defun p2-quote (form target representation)
    5929   (aver (or (null representation) (eq representation :boolean)))
    5930   (let ((obj (second form)))
    5931     (cond ((null obj)
    5932            (when target
    5933              (emit-push-false representation)
    5934              (emit-move-from-stack target representation)))
    5935           ((eq representation :boolean)
    5936            (emit 'iconst_1)
    5937            (emit-move-from-stack target representation))
    5938           ((keywordp obj)
    5939            (let ((name (lookup-known-keyword obj)))
    5940               (if name
    5941                   (emit 'getstatic "org/armedbear/lisp/Keyword" name +lisp-symbol+)
    5942                   (emit 'getstatic *this-class* (declare-keyword obj) +lisp-symbol+)))
    5943             (emit-move-from-stack target representation))
    5944           ((symbolp obj)
    5945            (let ((name (lookup-known-symbol obj)))
    5946              (cond (name
    5947                     (emit 'getstatic +lisp-symbol-class+ name +lisp-symbol+))
    5948                    ((symbol-package (truly-the symbol obj))
    5949                     (emit 'getstatic *this-class* (declare-symbol obj) +lisp-symbol+))
    5950                    (t
    5951                     ;; An uninterned symbol.
    5952                     (let ((g (if *compile-file-truename*
    5953                                  (declare-object-as-string obj)
    5954                                  (declare-object obj))))
    5955                       (emit 'getstatic *this-class* g +lisp-object+))))
    5956              (emit-move-from-stack target representation)))
    5957           ((listp obj)
    5958            (let ((g (if *compile-file-truename*
    5959                         (declare-object-as-string obj)
    5960                         (declare-object obj))))
    5961              (emit 'getstatic *this-class* g +lisp-object+)
    5962              (emit-move-from-stack target representation)))
    5963           ((constantp obj)
    5964            (compile-constant obj target representation))
    5965           (t
    5966            (compiler-unsupported "COMPILE-QUOTE: unsupported case: ~S" form)))))
    5967 
    5968 (defun p2-rplacd (form target representation)
    5969   (unless (check-arg-count form 2)
    5970     (compile-function-call form target representation)
    5971     (return-from p2-rplacd))
    5972   (let ((args (cdr form)))
    5973     (compile-form (first args) 'stack nil)
    5974     (when target
    5975       (emit 'dup))
    5976     (compile-form (second args) 'stack nil)
    5977     (emit-invokevirtual +lisp-object-class+
    5978                         "setCdr"
    5979                         (lisp-object-arg-types 1)
    5980                         nil)
    5981     (when target
    5982       (fix-boxing representation nil)
    5983       (emit-move-from-stack target representation))))
    5984 
    5985 (defun p2-set-car/cdr (form target representation)
    5986   (unless (check-arg-count form 2)
    5987     (compile-function-call form target representation)
    5988     (return-from p2-set-car/cdr))
    5989   (let ((op (%car form))
    5990         (args (%cdr form)))
    5991     (compile-form (%car args) 'stack nil)
    5992     (compile-form (%cadr args) 'stack nil)
    5993     (when target
    5994       (emit 'dup_x1))
    5995     (emit-invokevirtual +lisp-object-class+
    5996                         (if (eq op 'sys:set-car) "setCar" "setCdr")
    5997                         (lisp-object-arg-types 1)
    5998                         nil)
    5999     (when target
    6000       (fix-boxing representation nil)
    6001       (emit-move-from-stack target representation))))
    6002 
    6003 (defun compile-declare (form target representation)
    6004   (declare (ignore form representation))
    6005   (when target
    6006     (emit-push-nil)
    6007     (emit-move-from-stack target)))
    6008 
    6009 (defknown p2-flet-process-compiland (t) t)
    6010 (defun p2-flet-process-compiland (local-function)
    6011   (let* ((compiland (local-function-compiland local-function))
    6012          (lambda-list (cadr (compiland-lambda-expression compiland))))
    6013     (cond (*compile-file-truename*
    6014            (let* ((pathname (sys::next-classfile-name))
    6015                   (class-file (make-class-file :pathname pathname
    6016                                                :lambda-list lambda-list)))
    6017              (setf (compiland-class-file compiland) class-file)
    6018              (with-class-file class-file
    6019                (let ((*current-compiland* compiland))
    6020                  (with-saved-compiler-policy
    6021                    (p2-compiland compiland)
    6022                    (write-class-file (compiland-class-file compiland)))))
    6023              ;; Verify that the class file is loadable.
    6024              (let ((*load-truename* (pathname pathname)))
    6025                (unless (ignore-errors (load-compiled-function pathname))
    6026                  (error "Unable to load ~S." pathname)))
    6027              (setf (local-function-class-file local-function) class-file))
    6028 
    6029            (when (local-function-variable local-function)
    6030              (let ((g (declare-local-function local-function)))
    6031                (emit 'getstatic *this-class* g +lisp-object+)
    6032 
    6033                (let ((parent (compiland-parent compiland)))
    6034                  (when (compiland-closure-register parent)
    6035                    (dformat t "(compiland-closure-register parent) = ~S~%"
    6036                             (compiland-closure-register parent))
    6037                    (emit 'checkcast +lisp-ctf-class+)
    6038                    (emit 'aload (compiland-closure-register parent))
    6039                    (emit-invokestatic +lisp-class+ "makeCompiledClosure"
    6040                                       (list +lisp-object+ +lisp-object-array+)
    6041                                       +lisp-object+)))
    6042 
    6043                (dformat t "p2-flet-process-compiland var-set ~S~%" (variable-name (local-function-variable local-function)))
    6044                (emit 'var-set (local-function-variable local-function)))))
    6045           (t
    6046            (let* ((pathname (make-temp-file))
    6047                   (class-file (make-class-file :pathname pathname
    6048                                                :lambda-list lambda-list)))
    6049              (setf (compiland-class-file compiland) class-file)
    6050              (unwind-protect
    6051                  (progn
    6052                    (with-class-file class-file
    6053                      (let ((*current-compiland* compiland))
    6054                        (with-saved-compiler-policy
    6055                          (p2-compiland compiland)
    6056                          (write-class-file (compiland-class-file compiland)))))
    6057                    (setf (local-function-class-file local-function) class-file)
    6058                    (setf (local-function-function local-function) (load-compiled-function pathname))
    6059 
    6060                    (when (local-function-variable local-function)
    6061                      (let ((g (declare-object (load-compiled-function pathname))))
    6062                        (emit 'getstatic *this-class* g +lisp-object+)
    6063 
    6064                        (let ((parent (compiland-parent compiland)))
    6065                          (when (compiland-closure-register parent)
    6066                            (dformat t "(compiland-closure-register parent) = ~S~%"
    6067                                     (compiland-closure-register parent))
    6068                            (emit 'checkcast +lisp-ctf-class+)
    6069                            (emit 'aload (compiland-closure-register parent))
    6070                            (emit-invokestatic +lisp-class+ "makeCompiledClosure"
    6071                                               (list +lisp-object+ +lisp-object-array+)
    6072                                               +lisp-object+)))
    6073 
    6074                        (emit 'var-set (local-function-variable local-function)))))
    6075                (delete-file pathname)))))))
    6076 
    6077 (defknown p2-labels-process-compiland (t) t)
    6078 (defun p2-labels-process-compiland (local-function)
    6079   (let* ((compiland (local-function-compiland local-function))
    6080          (lambda-list (cadr (compiland-lambda-expression compiland))))
    6081     (cond (*compile-file-truename*
    6082            (let* ((pathname (sys::next-classfile-name))
    6083                   (class-file (make-class-file :pathname pathname
    6084                                                :lambda-list lambda-list)))
    6085              (setf (compiland-class-file compiland) class-file)
    6086              (with-class-file class-file
    6087                (let ((*current-compiland* compiland))
    6088                  (with-saved-compiler-policy
    6089                    (p2-compiland compiland)
    6090                    (write-class-file (compiland-class-file compiland)))))
    6091              ;; Verify that the class file is loadable.
    6092              (let ((*load-truename* (pathname pathname)))
    6093                (unless (ignore-errors (load-compiled-function pathname))
    6094                  (error "Unable to load ~S." pathname)))
    6095              (setf (local-function-class-file local-function) class-file)
    6096              (let ((g (declare-local-function local-function)))
    6097                (emit 'getstatic *this-class* g +lisp-object+)
    6098 
    6099                (let ((parent (compiland-parent compiland)))
    6100                  (when (compiland-closure-register parent)
    6101                    (dformat t "(compiland-closure-register parent) = ~S~%"
    6102                             (compiland-closure-register parent))
    6103                    (emit 'checkcast +lisp-ctf-class+)
    6104                    (emit 'aload (compiland-closure-register parent))
    6105                    (emit-invokestatic +lisp-class+ "makeCompiledClosure"
    6106                                       (list +lisp-object+ +lisp-object-array+)
    6107                                       +lisp-object+)))
    6108 
    6109 
    6110                (emit 'var-set (local-function-variable local-function)))))
    6111           (t
    6112            (let* ((pathname (make-temp-file))
    6113                   (class-file (make-class-file :pathname pathname
    6114                                                :lambda-list lambda-list)))
    6115              (setf (compiland-class-file compiland) class-file)
    6116              (unwind-protect
    6117                  (progn
    6118                    (with-class-file class-file
    6119                      (let ((*current-compiland* compiland))
    6120                        (with-saved-compiler-policy
    6121                          (p2-compiland compiland)
    6122                          (write-class-file (compiland-class-file compiland)))))
    6123                    (setf (local-function-class-file local-function) class-file)
    6124                    (let ((g (declare-object (load-compiled-function pathname))))
    6125                      (emit 'getstatic *this-class* g +lisp-object+)
    6126 
    6127                      (let ((parent (compiland-parent compiland)))
    6128                        (when (compiland-closure-register parent)
    6129                          (dformat t "(compiland-closure-register parent) = ~S~%"
    6130                                   (compiland-closure-register parent))
    6131                          (emit 'checkcast +lisp-ctf-class+)
    6132                          (emit 'aload (compiland-closure-register parent))
    6133                          (emit-invokestatic +lisp-class+ "makeCompiledClosure"
    6134                                             (list +lisp-object+ +lisp-object-array+)
    6135                                             +lisp-object+)))
    6136 
    6137                      (emit 'var-set (local-function-variable local-function))))
    6138                (delete-file pathname)))))))
    6139 
    6140 (defknown p2-flet (t t t) t)
    6141 (defun p2-flet (form target representation)
    6142   ;; FIXME What if we're called with a non-NIL representation?
    6143   (declare (ignore representation))
    6144   (let ((*local-functions* *local-functions*)
    6145         (*visible-variables* *visible-variables*)
    6146         (local-functions (cadr form))
    6147         (body (cddr form)))
    6148     (dolist (local-function local-functions)
    6149       (let ((variable (local-function-variable local-function)))
    6150         (when variable
    6151           (aver (null (variable-register variable)))
    6152           (unless (variable-closure-index variable)
    6153             (setf (variable-register variable) (allocate-register))))))
    6154     (dolist (local-function local-functions)
    6155       (p2-flet-process-compiland local-function))
    6156     (dolist (local-function local-functions)
    6157       (push local-function *local-functions*)
    6158       (let ((variable (local-function-variable local-function)))
    6159         (when variable
    6160           (push variable *visible-variables*))))
    6161     (do ((forms body (cdr forms)))
    6162         ((null forms))
    6163       (compile-form (car forms) (if (cdr forms) nil target) nil))))
    6164 
    6165 (defknown p2-labels (t t t) t)
    6166 (defun p2-labels (form target representation)
    6167   (let ((*local-functions* *local-functions*)
    6168         (*visible-variables* *visible-variables*)
    6169         (local-functions (cadr form))
    6170         (body (cddr form)))
    6171     (dolist (local-function local-functions)
    6172       (push local-function *local-functions*)
    6173       (push (local-function-variable local-function) *visible-variables*))
    6174     (dolist (local-function local-functions)
    6175       (let ((variable (local-function-variable local-function)))
    6176         (aver (null (variable-register variable)))
    6177         (unless (variable-closure-index variable)
    6178           (setf (variable-register variable) (allocate-register)))))
    6179     (dolist (local-function local-functions)
    6180       (p2-labels-process-compiland local-function))
    6181     (do ((forms body (cdr forms)))
    6182         ((null forms))
    6183       (compile-form (car forms) (if (cdr forms) nil 'stack) nil))
    6184     (fix-boxing representation nil)
    6185     (emit-move-from-stack target representation)))
    6186 
    6187 (defun p2-lambda (compiland target)
    6188   (let* ((lambda-list (cadr (compiland-lambda-expression compiland))))
    6189     (aver (null (compiland-class-file compiland)))
    6190     (cond (*compile-file-truename*
    6191            (setf (compiland-class-file compiland)
    6192                  (make-class-file :pathname (sys::next-classfile-name)
    6193                                   :lambda-list lambda-list))
    6194            (with-class-file (compiland-class-file compiland)
    6195              (let ((*current-compiland* compiland))
    6196                (with-saved-compiler-policy
    6197                  (p2-compiland compiland)
    6198                  (write-class-file (compiland-class-file compiland)))))
    6199            (let ((class-file (compiland-class-file compiland)))
    6200              (emit 'getstatic *this-class*
    6201                    (declare-local-function (make-local-function :class-file class-file))
    6202                    +lisp-object+)))
    6203           (t
    6204            (let ((pathname (make-temp-file)))
    6205              (setf (compiland-class-file compiland)
    6206                    (make-class-file :pathname pathname
    6207                                     :lambda-list lambda-list))
    6208              (unwind-protect
    6209                  (progn
    6210                    (with-class-file (compiland-class-file compiland)
    6211                      (let ((*current-compiland* compiland))
    6212                        (with-saved-compiler-policy
    6213                          (p2-compiland compiland)
    6214                          (write-class-file (compiland-class-file compiland)))))
    6215                    (emit 'getstatic *this-class*
    6216                          (declare-object (load-compiled-function pathname))
    6217                          +lisp-object+))
    6218                (delete-file pathname)))))
    6219     (cond ((null *closure-variables*)) ; Nothing to do.
    6220           ((compiland-closure-register *current-compiland*)
    6221            (emit 'aload (compiland-closure-register *current-compiland*))
    6222            (emit-invokestatic +lisp-class+ "makeCompiledClosure"
    6223                               (list +lisp-object+ +lisp-object-array+)
    6224                               +lisp-object+)
    6225            (emit 'checkcast +lisp-compiled-closure-class+)) ; Stack: compiled-closure
    6226           (t
    6227            (aver nil))) ;; Shouldn't happen.
    6228     (emit-move-from-stack target)))
    6229 
    6230 (defknown p2-function (t t t) t)
    6231 (defun p2-function (form target representation)
    6232   ;; FIXME What if we're called with a non-NIL representation?
    6233   (declare (ignore representation))
    6234   (let ((name (second form))
    6235         local-function)
    6236     (cond ((symbolp name)
    6237            (dformat t "p2-function case 1~%")
    6238            (cond ((setf local-function (find-local-function name))
    6239                   (dformat t "p2-function 1~%")
    6240                   (cond ((local-function-variable local-function)
    6241                          (dformat t "p2-function 2 emitting var-ref~%")
    6242 ;;                          (emit 'var-ref (local-function-variable local-function) 'stack)
    6243                          (compile-var-ref (make-var-ref (local-function-variable local-function)) 'stack nil)
    6244                          )
    6245                         (t
    6246                          (let ((g (if *compile-file-truename*
    6247                                       (declare-local-function local-function)
    6248                           &nb