Changeset 8403


Ignore:
Timestamp:
01/27/05 02:17:58 (16 years ago)
Author:
piso
Message:

Work in progress (tested).

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/jvm.lisp

    r8402 r8403  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: jvm.lisp,v 1.372 2005-01-25 20:15:42 piso Exp $
     4;;; $Id: jvm.lisp,v 1.373 2005-01-27 02:17:58 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    7878(defvar *static-code* ())
    7979
     80(defvar *declared-symbols* nil)
     81(defvar *declared-functions* nil)
     82(defvar *declared-strings* nil)
     83(defvar *declared-fixnums* nil)
     84
    8085(defstruct (class-file (:constructor %make-class-file))
    8186  pathname ; pathname of output file
     
    8893  fields
    8994  methods
    90   static-code)
     95  static-code
     96  (symbols (make-hash-table :test 'eq))
     97  (functions (make-hash-table :test 'equal))
     98  (strings (make-hash-table :test 'eq))
     99  (fixnums (make-hash-table :test 'eql))
     100  )
    91101
    92102(defun class-name-from-filespec (filespec)
     
    107117  (let ((var (gensym)))
    108118    `(let* ((,var ,class-file)
    109             (*pool* (class-file-pool ,var))
    110             (*pool-count* (class-file-pool-count ,var))
    111             (*pool-entries* (class-file-pool-entries ,var))
    112             (*fields* (class-file-fields ,var))
    113             (*static-code* (class-file-static-code ,var)))
     119            (*pool*               (class-file-pool ,var))
     120            (*pool-count*         (class-file-pool-count ,var))
     121            (*pool-entries*       (class-file-pool-entries ,var))
     122            (*fields*             (class-file-fields ,var))
     123            (*static-code*        (class-file-static-code ,var))
     124            (*declared-symbols*   (class-file-symbols ,var))
     125            (*declared-functions* (class-file-functions ,var))
     126            (*declared-strings*   (class-file-strings ,var))
     127            (*declared-fixnums*   (class-file-fixnums ,var)))
    114128       (progn ,@body)
    115        (setf (class-file-pool ,var) *pool*
    116              (class-file-pool-count ,var) *pool-count*
     129       (setf (class-file-pool ,var)         *pool*
     130             (class-file-pool-count ,var)   *pool-count*
    117131             (class-file-pool-entries ,var) *pool-entries*
    118              (class-file-fields ,var) *fields*
    119              (class-file-static-code ,var) *static-code*
     132             (class-file-fields ,var)       *fields*
     133             (class-file-static-code ,var)  *static-code*
     134             (class-file-symbols ,var)      *declared-symbols*
     135             (class-file-functions ,var)    *declared-functions*
     136             (class-file-strings ,var)      *declared-strings*
     137             (class-file-fixnums ,var)      *declared-fixnums*
    120138             ))))
    121139
    122140(defstruct compiland
    123141  name
     142  (kind :external) ; :INTERNAL or :EXTERNAL
    124143  lambda-expression
    125144  arg-vars
     145  arity ; NIL if the number of args can vary.
    126146  p1-result
    127147  parent
     
    259279(defvar *using-arg-array* nil)
    260280(defvar *hairy-arglist-p* nil)
    261 (defvar *arity* nil)
    262281
    263282(defvar *val* nil) ; index of value register
     
    869888
    870889(defun inst (instr &optional args)
     890  (declare (optimize speed))
    871891  (let ((opcode (if (numberp instr)
    872892                    instr
     
    9891009  (emit 'aload *thread*))
    9901010
    991 (defun maybe-generate-arg-count-check ()
    992   (when *arity*
    993     (let ((label1 (gensym)))
    994       (aver (fixnump *arity*))
    995       (aver (not (minusp *arity*)))
    996       (aver (not (null (compiland-argument-register *current-compiland*))))
    997       (emit 'aload (compiland-argument-register *current-compiland*))
    998       (emit 'arraylength)
    999       (emit 'bipush *arity*)
    1000       (emit 'if_icmpeq `,label1)
    1001       (emit 'aload 0) ; this
    1002       (emit-invokevirtual *this-class* "argCountError" nil nil)
    1003       (emit 'label `,label1))))
     1011(defun generate-arg-count-check (arity)
     1012  (aver (fixnump arity))
     1013  (aver (not (minusp arity)))
     1014  (aver (not (null (compiland-argument-register *current-compiland*))))
     1015  (let ((label1 (gensym)))
     1016    (emit 'aload (compiland-argument-register *current-compiland*))
     1017    (emit 'arraylength)
     1018    (emit 'bipush arity)
     1019    (emit 'if_icmpeq `,label1)
     1020    (emit 'aload 0) ; this
     1021    (emit-invokevirtual *this-class* "argCountError" nil nil)
     1022    (emit 'label `,label1)))
    10041023
    10051024(defun maybe-generate-interrupt-check ()
     
    18671886    (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor)))
    18681887    (setf (method-max-locals constructor) 1)
    1869     (cond (;;*hairy-arglist-p*
    1870            (equal super +lisp-compiled-function-class+)
    1871 
     1888    (cond ((equal super +lisp-compiled-function-class+)
    18721889           (emit 'aload_0) ;; this
    18731890           (emit 'aconst_null) ;; name
     
    18861903           (emit 'aload_0)
    18871904           (emit-invokespecial-init super nil))
    1888 ;;           (*child-p*
    1889 ;;            (cond ((null *closure-variables*)
    1890 ;;                   (emit 'aload_0)
    1891 ;;                   (emit-invokespecial-init super nil))
    1892 ;;                  (t
    1893 ;;                   (emit 'aload_0) ;; this
    1894 ;;                   (let* ((*print-level* nil)
    1895 ;;                          (*print-length* nil)
    1896 ;;                          (s (%format nil "~S" args)))
    1897 ;;                     (emit 'ldc (pool-string s))
    1898 ;;                     (emit-invokestatic +lisp-class+ "readObjectFromString"
    1899 ;;                                        (list +java-string+) +lisp-object+))
    1900 ;;                   (emit-invokespecial-init super (list +lisp-object+)))))
    1901 ;;           (t
    1902 ;;            (emit 'aload_0)
    1903 ;;            (emit-invokespecial-init super nil)))
    19041905          ((equal super +lisp-ctf-class+)
    19051906           (emit 'aload_0) ;; this
     
    19131914          (t
    19141915           (aver nil)))
    1915 
    19161916    (setf *code* (append *static-code* *code*))
    19171917    (emit 'return)
     
    19891989    (when (plusp (length output))
    19901990      output)))
    1991 
    1992 (defvar *declared-symbols* nil)
    1993 (defvar *declared-functions* nil)
    1994 (defvar *declared-strings* nil)
    1995 (defvar *declared-fixnums* nil)
    19961991
    19971992(defun declare-symbol (symbol)
     
    47604755
    47614756;; Returns descriptor.
    4762 (defun analyze-args (args)
    4763   (aver (not (memq '&AUX args)))
    4764   (let ((arg-count (length args)))
     4757(defun analyze-args (compiland)
     4758  (let* ((args (cadr (compiland-p1-result compiland)))
     4759         (arg-count (length args)))
     4760    (dformat t "analyze-args args = ~S~%" args)
     4761    (aver (not (memq '&AUX args)))
    47654762
    47664763    (when *child-p*
     
    47834780                                                 +lisp-object+))
    47844781                                (t (setf *using-arg-array* t)
    4785                                    (setf *arity* arg-count)
     4782                                   (setf (compiland-arity compiland) arg-count)
    47864783                                   (get-descriptor (list +lisp-object-array+ +lisp-object-array+)
    47874784                                                   +lisp-object+)))))
     
    47924789                                                 +lisp-object+))
    47934790                                (t (setf *using-arg-array* t)
    4794                                    (setf *arity* arg-count)
     4791                                   (setf (compiland-arity compiland) arg-count)
    47954792                                   (get-descriptor (list +lisp-object-array+)
    47964793                                                   +lisp-object+)))))))
     
    48074804          (t
    48084805           (setf *using-arg-array* t)
    4809            (setf *arity* arg-count)
     4806           (setf (compiland-arity compiland) arg-count)
    48104807           (get-descriptor (list +lisp-object-array+) +lisp-object+)))))
    48114808
     
    48394836        (write-field field stream))
    48404837      ;; methods count
    4841       (write-u2 2 stream)
     4838      (write-u2 (1+ (length (class-file-methods class-file))) stream)
    48424839      ;; methods
    4843       (aver (= (length (class-file-methods class-file)) 1))
    4844       (let ((execute-method (car (class-file-methods class-file))))
    4845         (write-method execute-method stream)
    4846         )
     4840;;       (aver (= (length (class-file-methods class-file)) 1))
     4841;;       (let ((execute-method (car (class-file-methods class-file))))
     4842;;         (write-method execute-method stream))
     4843      (dolist (method (class-file-methods class-file))
     4844        (write-method method stream))
    48474845      (write-method constructor stream)
    48484846      ;; attributes count
    48494847      (write-u2 0 stream))))
     4848
     4849(defvar *magic* t)
     4850
     4851(defun compile-xep (xep)
     4852  (declare (type compiland xep))
     4853  (let ((*all-variables* ())
     4854        (*closure-variables* ())
     4855        (*current-compiland* xep)
     4856        (*child-count* 0)
     4857        (*speed* 3)
     4858        (*safety* 0)
     4859        (*debug* 0))
     4860    ;; Pass 1.
     4861    (p1-compiland xep)
     4862;;     (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*))
     4863    (setf *closure-variables*
     4864          (remove-if-not #'variable-used-non-locally-p *all-variables*))
     4865    (setf *closure-variables*
     4866          (remove-if #'variable-special-p *closure-variables*))
     4867;;     (dformat t "*closure-variables* = ~S~%" (mapcar #'variable-name *closure-variables*))
     4868
     4869    (when *closure-variables*
     4870      (let ((i 0))
     4871        (dolist (var (reverse *closure-variables*))
     4872          (setf (variable-closure-index var) i)
     4873          (dformat t "var = ~S closure index = ~S~%" (variable-name var)
     4874                   (variable-closure-index var))
     4875          (incf i))))
     4876
     4877    ;; Pass 2.
     4878    (with-class-file (compiland-class-file xep)
     4879      (p2-compiland xep))))
    48504880
    48514881(defun p1-compiland (compiland)
     
    48624892
    48634893
    4864       #+nil
    4865       (unless (or (memq '&KEY lambda-list) (memq '&REST lambda-list))
    4866         (let ((optionals (memq '&OPTIONAL lambda-list)))
    4867           (dformat t "optionals = ~S~%" optionals)
    4868           (when (= (length optionals) 2)
    4869             (let* ((optional-arg (second optionals))
    4870                    (name (if (consp optional-arg) (car optional-arg) optional-arg))
    4871                    (initform (if (consp optional-arg) (cadr optional-arg) nil))
    4872                    (wrapper-args (subseq lambda-list 0 (position '&OPTIONAL lambda-list)))
    4873                    (converted-args (append wrapper-args (list name))))
    4874               (dformat t "optional-arg = ~S~%" optional-arg)
    4875               (dformat t "wrapper-args = ~S~%" wrapper-args)
    4876               (dformat t "converted-args = ~S~%" converted-args)
    4877               (let ((wrapper-form
    4878                      `(lambda ,wrapper-args
    4879                         (let ((,name ,initform))
    4880                           (,(compiland-name compiland) ,@converted-args)))))
    4881                 (dformat t "wrapper-form = ~S~%" wrapper-form)
     4894      (when *magic*
     4895        (when (memq '&OPTIONAL lambda-list)
     4896          (unless (or (memq '&KEY lambda-list) (memq '&REST lambda-list))
     4897            (let ((required-args (subseq lambda-list 0 (position '&OPTIONAL lambda-list)))
     4898                  (optional-args (cdr (memq '&OPTIONAL lambda-list)))
     4899;;                   (*enable-dformat* t)
    48824900                )
    4883               ))))
    4884 
     4901            (dformat t "optional-args = ~S~%" optional-args)
     4902            (when (= (length optional-args) 1)
     4903;;               (%format t "~%magic case~%")
     4904              (let* ((optional-arg (car optional-args))
     4905                     (name (if (consp optional-arg) (car optional-arg) optional-arg))
     4906                     (initform (if (consp optional-arg) (cadr optional-arg) nil))
     4907                     (supplied-p-var (and (consp optional-arg)
     4908                                          (= (length optional-arg) 3)
     4909                                          (third optional-arg)))
     4910                     (all-args
     4911                      (append required-args (list name)
     4912                              (when supplied-p-var (list supplied-p-var)))))
     4913                (when (<= (length all-args) 4)
     4914                  (dformat t "optional-arg = ~S~%" optional-arg)
     4915                  (dformat t "supplied-p-var = ~S~%" supplied-p-var)
     4916                  (dformat t "required-args = ~S~%" required-args)
     4917                  (dformat t "all-args = ~S~%" all-args)
     4918                  (cond (supplied-p-var
     4919                         (let ((xep-lambda-expression
     4920                                `(lambda ,required-args
     4921                                   (let* ((,name ,initform)
     4922                                          (,supplied-p-var nil))
     4923                                     (%call-internal ,@all-args)))))
     4924                           (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression)
     4925                           (let ((xep-compiland
     4926                                  (make-compiland :lambda-expression (precompile-form xep-lambda-expression t)
     4927                                                  :class-file (compiland-class-file compiland))))
     4928                             (compile-xep xep-compiland))
     4929                           )
     4930                         (let ((xep-lambda-expression
     4931                                `(lambda ,(append required-args (list name))
     4932                                   (let* ((,supplied-p-var t))
     4933                                     (%call-internal ,@all-args)))))
     4934                           (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression)
     4935                           (let ((xep-compiland
     4936                                  (make-compiland :lambda-expression (precompile-form xep-lambda-expression t)
     4937                                                  :class-file (compiland-class-file compiland))))
     4938                             (compile-xep xep-compiland))
     4939                           )
     4940                         (setf lambda-list all-args)
     4941                         (setf (compiland-kind compiland) :internal)
     4942                         )
     4943                        (t
     4944                         (let ((xep-lambda-expression
     4945                                `(lambda ,required-args
     4946                                   (let* ((,name ,initform))
     4947                                     (,(compiland-name compiland) ,@all-args)))))
     4948                           (dformat t "xep-lambda-expression = ~S~%" xep-lambda-expression)
     4949                           (let ((xep-compiland
     4950                                  (make-compiland :lambda-expression (precompile-form xep-lambda-expression t)
     4951                                                  :class-file (compiland-class-file compiland))))
     4952                             (compile-xep xep-compiland)))
     4953                         (setf lambda-list all-args))))))))))
    48854954
    48864955      (let* ((closure (sys::make-closure `(lambda ,lambda-list nil) nil))
     
    49034972                (list* 'LAMBDA lambda-list (mapcar #'p1 body))))))))
    49044973
     4974(defun p2-%call-internal (form &key (target *val*) representation)
     4975  (dformat t "p2-%call-internal~%")
     4976  (emit 'aload_0) ; this
     4977  (let ((args (cdr form))
     4978        (must-clear-values nil))
     4979    (dformat t "args = ~S~%" args)
     4980    (dolist (arg args)
     4981      (compile-form arg :target :stack :representation nil)
     4982      (unless must-clear-values
     4983        (unless (single-valued-p arg)
     4984          (setf must-clear-values t))))
     4985    (let ((arg-types (make-list (length args) :initial-element +lisp-object+))
     4986          (return-type +lisp-object+))
     4987      (emit-invokevirtual *this-class* "_execute" arg-types return-type))
     4988    (emit-move-from-stack target representation)))
     4989
    49054990(defun p2-compiland (compiland)
    49064991  (dformat t "p2-compiland ~S~%" (compiland-name compiland))
    49074992  (let* ((p1-result (compiland-p1-result compiland))
    4908          (*declared-symbols* (make-hash-table :test 'eq))
    4909          (*declared-functions* (make-hash-table :test 'equal))
    4910          (*declared-strings* (make-hash-table :test 'eq))
    4911          (*declared-fixnums* (make-hash-table :test 'eql))
     4993;;          (*declared-symbols* (make-hash-table :test 'eq))
     4994;;          (*declared-functions* (make-hash-table :test 'equal))
     4995;;          (*declared-strings* (make-hash-table :test 'eq))
     4996;;          (*declared-fixnums* (make-hash-table :test 'eql))
    49124997         (class-file (compiland-class-file compiland))
    4913 ;;          (*this-class* (class-name-from-filespec (class-file-pathname class-file)))
    49144998         (*this-class* (class-file-class class-file))
    49154999         (args (cadr p1-result))
     
    49175001         (*using-arg-array* nil)
    49185002         (*hairy-arglist-p* nil)
    4919          (*arity* nil)
    49205003
    49215004         (*child-p* (not (null (compiland-parent compiland))))
    49225005
    4923          (descriptor (analyze-args args))
    4924          (execute-method (make-method :name "execute"
     5006         (descriptor (analyze-args compiland))
     5007         (execute-method-name (if (eq (compiland-kind compiland) :external)
     5008                                  "execute" "_execute"))
     5009         (execute-method (make-method :name execute-method-name
    49255010                                      :descriptor descriptor))
    49265011         (*code* ())
    4927 ;;          (*static-code* ())
    4928 ;;          (*fields* ())
    49295012         (*register* 0)
    49305013         (*registers-allocated* 0)
     
    49355018         (parameters ())
    49365019
    4937 ;;          (*pool* ())
    4938 ;;          (*pool-count* 1)
    4939 ;;          (*pool-entries* (make-hash-table :test #'equal))
    49405020         (*val* nil)
    49415021         (*thread* nil)
     
    49635043                  (vars (sys::varlist closure))
    49645044                  (index 0))
    4965              (dformat t "*hairy-arglist-p* = t vars = ~S~%" vars)
    49665045             (dolist (var vars)
    49675046               (let ((variable (find-visible-variable var)))
     
    49755054                 (incf index)))))
    49765055          (t
    4977            (dformat t "*hairy-arglist-p* = nil~%")
    49785056           (let ((register (if (and *closure-variables* *child-p*)
    49795057                               2 ; Reg 1 is reserved for closure variables array.
     
    51295207    (let ((code *code*))
    51305208      (setf *code* ())
    5131       (maybe-generate-arg-count-check)
     5209      (let ((arity (compiland-arity compiland)))
     5210        (when arity
     5211          (generate-arg-count-check arity)))
    51325212      (maybe-generate-interrupt-check)
    51335213
     
    51905270
    51915271;;     (write-class-file (compiland-class-file compiland))
    5192     (dformat t "leaving p2-compiland ~S~%" (compiland-name compiland))))
     5272    (dformat t "leaving p2-compiland ~S~%" (compiland-name compiland))
     5273    (values)))
    51935274
    51945275(defun compile-1 (compiland)
     
    52395320                               :class-file (make-class-file :pathname filespec
    52405321                                                            :lambda-list (cadr form))
    5241                                :parent *current-compiland*))))
     5322;;                                :parent *current-compiland*
     5323                               ))))
    52425324
    52435325(defun handle-warning (condition)
     
    54085490;; (install-p2-handler 'unwind-protect 'p2-unwind-protect)
    54095491
     5492(install-p2-handler '%call-internal 'p2-%call-internal)
     5493
    54105494(defun process-optimization-declarations (forms)
    54115495  (let (alist ())
Note: See TracChangeset for help on using the changeset viewer.