Changeset 8403
- Timestamp:
- 01/27/05 02:17:58 (18 years ago)
- File:
-
- 1 edited
-
trunk/j/src/org/armedbear/lisp/jvm.lisp (modified) (26 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/j/src/org/armedbear/lisp/jvm.lisp
r8402 r8403 2 2 ;;; 3 3 ;;; Copyright (C) 2003-2005 Peter Graves 4 ;;; $Id: jvm.lisp,v 1.37 2 2005-01-25 20:15:42piso Exp $4 ;;; $Id: jvm.lisp,v 1.373 2005-01-27 02:17:58 piso Exp $ 5 5 ;;; 6 6 ;;; This program is free software; you can redistribute it and/or … … 78 78 (defvar *static-code* ()) 79 79 80 (defvar *declared-symbols* nil) 81 (defvar *declared-functions* nil) 82 (defvar *declared-strings* nil) 83 (defvar *declared-fixnums* nil) 84 80 85 (defstruct (class-file (:constructor %make-class-file)) 81 86 pathname ; pathname of output file … … 88 93 fields 89 94 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 ) 91 101 92 102 (defun class-name-from-filespec (filespec) … … 107 117 (let ((var (gensym))) 108 118 `(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))) 114 128 (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* 117 131 (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* 120 138 )))) 121 139 122 140 (defstruct compiland 123 141 name 142 (kind :external) ; :INTERNAL or :EXTERNAL 124 143 lambda-expression 125 144 arg-vars 145 arity ; NIL if the number of args can vary. 126 146 p1-result 127 147 parent … … 259 279 (defvar *using-arg-array* nil) 260 280 (defvar *hairy-arglist-p* nil) 261 (defvar *arity* nil)262 281 263 282 (defvar *val* nil) ; index of value register … … 869 888 870 889 (defun inst (instr &optional args) 890 (declare (optimize speed)) 871 891 (let ((opcode (if (numberp instr) 872 892 instr … … 989 1009 (emit 'aload *thread*)) 990 1010 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))) 1004 1023 1005 1024 (defun maybe-generate-interrupt-check () … … 1867 1886 (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor))) 1868 1887 (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+) 1872 1889 (emit 'aload_0) ;; this 1873 1890 (emit 'aconst_null) ;; name … … 1886 1903 (emit 'aload_0) 1887 1904 (emit-invokespecial-init super nil)) 1888 ;; (*child-p*1889 ;; (cond ((null *closure-variables*)1890 ;; (emit 'aload_0)1891 ;; (emit-invokespecial-init super nil))1892 ;; (t1893 ;; (emit 'aload_0) ;; this1894 ;; (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 ;; (t1902 ;; (emit 'aload_0)1903 ;; (emit-invokespecial-init super nil)))1904 1905 ((equal super +lisp-ctf-class+) 1905 1906 (emit 'aload_0) ;; this … … 1913 1914 (t 1914 1915 (aver nil))) 1915 1916 1916 (setf *code* (append *static-code* *code*)) 1917 1917 (emit 'return) … … 1989 1989 (when (plusp (length output)) 1990 1990 output))) 1991 1992 (defvar *declared-symbols* nil)1993 (defvar *declared-functions* nil)1994 (defvar *declared-strings* nil)1995 (defvar *declared-fixnums* nil)1996 1991 1997 1992 (defun declare-symbol (symbol) … … 4760 4755 4761 4756 ;; 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))) 4765 4762 4766 4763 (when *child-p* … … 4783 4780 +lisp-object+)) 4784 4781 (t (setf *using-arg-array* t) 4785 (setf *arity*arg-count)4782 (setf (compiland-arity compiland) arg-count) 4786 4783 (get-descriptor (list +lisp-object-array+ +lisp-object-array+) 4787 4784 +lisp-object+))))) … … 4792 4789 +lisp-object+)) 4793 4790 (t (setf *using-arg-array* t) 4794 (setf *arity*arg-count)4791 (setf (compiland-arity compiland) arg-count) 4795 4792 (get-descriptor (list +lisp-object-array+) 4796 4793 +lisp-object+))))))) … … 4807 4804 (t 4808 4805 (setf *using-arg-array* t) 4809 (setf *arity*arg-count)4806 (setf (compiland-arity compiland) arg-count) 4810 4807 (get-descriptor (list +lisp-object-array+) +lisp-object+))))) 4811 4808 … … 4839 4836 (write-field field stream)) 4840 4837 ;; methods count 4841 (write-u2 2stream)4838 (write-u2 (1+ (length (class-file-methods class-file))) stream) 4842 4839 ;; 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)) 4847 4845 (write-method constructor stream) 4848 4846 ;; attributes count 4849 4847 (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)))) 4850 4880 4851 4881 (defun p1-compiland (compiland) … … 4862 4892 4863 4893 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) 4882 4900 ) 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)))))))))) 4885 4954 4886 4955 (let* ((closure (sys::make-closure `(lambda ,lambda-list nil) nil)) … … 4903 4972 (list* 'LAMBDA lambda-list (mapcar #'p1 body)))))))) 4904 4973 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 4905 4990 (defun p2-compiland (compiland) 4906 4991 (dformat t "p2-compiland ~S~%" (compiland-name compiland)) 4907 4992 (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)) 4912 4997 (class-file (compiland-class-file compiland)) 4913 ;; (*this-class* (class-name-from-filespec (class-file-pathname class-file)))4914 4998 (*this-class* (class-file-class class-file)) 4915 4999 (args (cadr p1-result)) … … 4917 5001 (*using-arg-array* nil) 4918 5002 (*hairy-arglist-p* nil) 4919 (*arity* nil)4920 5003 4921 5004 (*child-p* (not (null (compiland-parent compiland)))) 4922 5005 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 4925 5010 :descriptor descriptor)) 4926 5011 (*code* ()) 4927 ;; (*static-code* ())4928 ;; (*fields* ())4929 5012 (*register* 0) 4930 5013 (*registers-allocated* 0) … … 4935 5018 (parameters ()) 4936 5019 4937 ;; (*pool* ())4938 ;; (*pool-count* 1)4939 ;; (*pool-entries* (make-hash-table :test #'equal))4940 5020 (*val* nil) 4941 5021 (*thread* nil) … … 4963 5043 (vars (sys::varlist closure)) 4964 5044 (index 0)) 4965 (dformat t "*hairy-arglist-p* = t vars = ~S~%" vars)4966 5045 (dolist (var vars) 4967 5046 (let ((variable (find-visible-variable var))) … … 4975 5054 (incf index))))) 4976 5055 (t 4977 (dformat t "*hairy-arglist-p* = nil~%")4978 5056 (let ((register (if (and *closure-variables* *child-p*) 4979 5057 2 ; Reg 1 is reserved for closure variables array. … … 5129 5207 (let ((code *code*)) 5130 5208 (setf *code* ()) 5131 (maybe-generate-arg-count-check) 5209 (let ((arity (compiland-arity compiland))) 5210 (when arity 5211 (generate-arg-count-check arity))) 5132 5212 (maybe-generate-interrupt-check) 5133 5213 … … 5190 5270 5191 5271 ;; (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))) 5193 5274 5194 5275 (defun compile-1 (compiland) … … 5239 5320 :class-file (make-class-file :pathname filespec 5240 5321 :lambda-list (cadr form)) 5241 :parent *current-compiland*)))) 5322 ;; :parent *current-compiland* 5323 )))) 5242 5324 5243 5325 (defun handle-warning (condition) … … 5408 5490 ;; (install-p2-handler 'unwind-protect 'p2-unwind-protect) 5409 5491 5492 (install-p2-handler '%call-internal 'p2-%call-internal) 5493 5410 5494 (defun process-optimization-declarations (forms) 5411 5495 (let (alist ())
Note: See TracChangeset
for help on using the changeset viewer.
