Changeset 8387
- Timestamp:
- 01/23/05 03:23:35 (18 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/j/src/org/armedbear/lisp/jvm.lisp
r8386 r8387 2 2 ;;; 3 3 ;;; Copyright (C) 2003-2005 Peter Graves 4 ;;; $Id: jvm.lisp,v 1.36 3 2005-01-22 19:00:37piso Exp $4 ;;; $Id: jvm.lisp,v 1.364 2005-01-23 03:23:35 piso Exp $ 5 5 ;;; 6 6 ;;; This program is free software; you can redistribute it and/or … … 863 863 (defconstant +lisp-thread+ "Lorg/armedbear/lisp/LispThread;") 864 864 (defconstant +lisp-cons-class+ "org/armedbear/lisp/Cons") 865 (defconstant +lisp-cons+ "Lorg/armedbear/lisp/Cons;") 865 866 (defconstant +lisp-fixnum-class+ "org/armedbear/lisp/Fixnum") 866 867 (defconstant +lisp-fixnum+ "Lorg/armedbear/lisp/Fixnum;") … … 901 902 (princ (or return-type "V") s)))))) 902 903 903 (defun descriptor (designator) 904 (cond ((stringp designator) 905 designator) 906 ((listp designator) 907 (unless (= (length designator) 2) 908 (error "Bad method type descriptor ~S." designator)) 909 (make-descriptor (car designator) (cadr designator))) 910 (t 911 (error "Bad method type descriptor ~S." designator)))) 912 913 (defun emit-invokestatic (class-name method-name descriptor stack) 914 (aver stack) 915 (let ((instruction (emit 'invokestatic 916 class-name method-name (descriptor descriptor)))) 917 (setf (instruction-stack instruction) stack) 918 (aver (eql (instruction-stack instruction) stack)))) 919 920 (defun emit-invokespecial (class-name method-name descriptor stack) 921 (let ((instruction (emit 'invokespecial 922 class-name method-name (descriptor descriptor)))) 904 (defun %emit-invokestatic (class-name method-name descriptor stack) 905 (let ((instruction (emit 'invokestatic class-name method-name descriptor))) 923 906 (setf (instruction-stack instruction) stack))) 924 907 908 ;; FIXME 909 ;; The way we calculate the stack effect here assumes that each argument 910 ;; occupies one slot. This is NOT CORRECT for Java longs ("J")! 911 (defun emit-invokestatic (class-name method-name arg-types return-type) 912 (let* ((descriptor (make-descriptor arg-types return-type)) 913 (stack (- (if return-type 1 0) (length arg-types))) 914 (instruction (emit 'invokestatic 915 class-name method-name descriptor))) 916 (setf (instruction-stack instruction) stack))) 917 918 ;; FIXME 919 ;; The way we calculate the stack effect here assumes that each argument 920 ;; occupies one slot. This is NOT CORRECT for Java longs ("J")! 925 921 (defun emit-invokevirtual (class-name method-name arg-types return-type) 926 922 (let* ((descriptor (make-descriptor arg-types return-type)) … … 929 925 (setf (instruction-stack instruction) stack))) 930 926 927 (defun emit-invokespecial-init (class-name arg-types) 928 (let* ((descriptor (make-descriptor arg-types nil)) 929 (stack (- (1+ (length arg-types)))) 930 (instruction (emit 'invokespecial class-name "<init>" descriptor))) 931 (setf (instruction-stack instruction) stack))) 932 931 933 ;; Index of local variable used to hold the current thread. 932 934 (defvar *thread* nil) … … 936 938 (defun maybe-initialize-thread-var () 937 939 (when *initialize-thread-var* 938 (emit-invokestatic +lisp-thread-class+ 939 "currentThread" 940 (make-descriptor () +lisp-thread+) 941 1) 940 (emit-invokestatic +lisp-thread-class+ "currentThread" nil +lisp-thread+) 942 941 (emit 'astore *thread*))) 943 942 … … 969 968 (emit 'getstatic +lisp-class+ "interrupted" "Z") 970 969 (emit 'ifeq `,label1) 971 (emit-invokestatic +lisp-class+ 972 "handleInterrupt" 973 "()V" 974 0) 970 (emit-invokestatic +lisp-class+ "handleInterrupt" nil nil) 975 971 (emit 'label `,label1)))) 976 972 … … 1124 1120 (declare (optimize speed)) 1125 1121 (cond ((= *safety* 3) 1126 (emit-invokestatic +lisp-fixnum-class+ 1127 "getValue" 1128 "(Lorg/armedbear/lisp/LispObject;)I" 1129 0)) 1122 (emit-invokestatic +lisp-fixnum-class+ "getValue" 1123 (list +lisp-object+) "I")) 1130 1124 (t 1131 1125 (emit 'checkcast +lisp-fixnum-class+) … … 1134 1128 (defun emit-box-long () 1135 1129 (declare (optimize speed)) 1136 (emit-invokestatic +lisp-class+ 1137 1138 "(J)Lorg/armedbear/lisp/LispObject;"1139 -1))1130 ;; (emit-invokestatic +lisp-class+ "number" (list "J") +lisp-object+) 1131 (%emit-invokestatic +lisp-class+ "number" 1132 (make-descriptor (list "J") +lisp-object+) 1133 -1)) 1140 1134 1141 1135 ;; Expects value on stack. … … 1828 1822 handlers) 1829 1823 1830 (defun make-constructor (super name args body)1824 (defun make-constructor (super name args) 1831 1825 (let* ((*compiler-debug* nil) ; We don't normally need to see debugging output for constructors. 1832 1826 (constructor (make-method :name "<init>" … … 1838 1832 (setf (method-descriptor-index constructor) (pool-name (method-descriptor constructor))) 1839 1833 (setf (method-max-locals constructor) 1) 1840 (cond 1841 (*hairy-arglist-p* 1842 (emit 'aload_0) ;; this 1843 (emit 'aconst_null) ;; name 1844 (let* ((*print-level* nil) 1845 (*print-length* nil) 1846 (s (%format nil "~S" args))) 1847 (emit 'ldc 1848 (pool-string s)) 1849 (emit-invokestatic +lisp-class+ 1850 "readObjectFromString" 1851 "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;" 1852 0)) 1853 (emit-push-nil) ;; body 1854 (emit 'aconst_null) ;; environment 1855 (emit-invokespecial super 1856 "<init>" 1857 ;; "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/Environment;)V" 1858 ;; `((,+lisp-symbol+ ,+lisp-object+ ,+lisp-object+ ,+lisp-environment+) nil) 1859 (make-descriptor (list +lisp-symbol+ +lisp-object+ +lisp-object+ +lisp-environment+) 1860 nil) 1861 -5)) 1862 (*child-p* 1863 (cond 1864 ((null *closure-variables*) 1865 (emit 'aload_0) 1866 (emit-invokespecial super 1867 "<init>" 1868 "()V" 1869 -1)) 1870 (t 1871 (emit 'aload_0) ;; this 1872 (let* ((*print-level* nil) 1873 (*print-length* nil) 1874 (s (%format nil "~S" args))) 1875 (emit 'ldc 1876 (pool-string s)) 1877 (emit-invokestatic +lisp-class+ 1878 "readObjectFromString" 1879 "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;" 1880 0)) 1881 (emit-invokespecial super 1882 "<init>" 1883 "(Lorg/armedbear/lisp/LispObject;)V" 1884 -2)))) 1885 (t 1886 (emit 'aload_0) 1887 (emit-invokespecial super 1888 "<init>" 1889 "()V" 1890 -1))) 1834 (cond (*hairy-arglist-p* 1835 (emit 'aload_0) ;; this 1836 (emit 'aconst_null) ;; name 1837 (let* ((*print-level* nil) 1838 (*print-length* nil) 1839 (s (%format nil "~S" args))) 1840 (emit 'ldc (pool-string s)) 1841 (emit-invokestatic +lisp-class+ "readObjectFromString" 1842 (list +java-string+) +lisp-object+)) 1843 (emit-push-nil) ;; body 1844 (emit 'aconst_null) ;; environment 1845 (emit-invokespecial-init super 1846 (list +lisp-symbol+ +lisp-object+ 1847 +lisp-object+ +lisp-environment+))) 1848 (*child-p* 1849 (cond ((null *closure-variables*) 1850 (emit 'aload_0) 1851 (emit-invokespecial-init super nil)) 1852 (t (emit 'aload_0) ;; this 1853 (let* ((*print-level* nil) 1854 (*print-length* nil) 1855 (s (%format nil "~S" args))) 1856 (emit 'ldc (pool-string s)) 1857 (emit-invokestatic +lisp-class+ "readObjectFromString" 1858 (list +java-string+) +lisp-object+)) 1859 (emit-invokespecial-init super (list +lisp-object+))))) 1860 (t (emit 'aload_0) 1861 (emit-invokespecial-init super nil))) 1891 1862 (setf *code* (append *static-code* *code*)) 1892 1863 (emit 'return) 1893 1864 (finalize-code) 1894 ;;(optimize-code)1865 ;;(optimize-code) 1895 1866 (setf *code* (resolve-instructions *code*)) 1896 1867 (setf (method-max-stack constructor) (analyze-stack)) … … 1981 1952 (emit 'ldc (pool-string (symbol-name symbol))) 1982 1953 (emit 'ldc (pool-string (package-name (symbol-package symbol)))) 1983 (emit-invokestatic +lisp-class+ 1984 "internInPackage" 1985 "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;" 1986 -1) 1987 (emit 'putstatic 1988 *this-class* 1989 g 1990 +lisp-symbol+) 1954 (emit-invokestatic +lisp-class+ "internInPackage" 1955 (list +java-string+ +java-string+) +lisp-symbol+) 1956 (emit 'putstatic *this-class* g +lisp-symbol+) 1991 1957 (setf *static-code* *code*) 1992 1958 (setf (gethash symbol *declared-symbols*) g))) … … 2000 1966 (declare-field g +lisp-symbol+) 2001 1967 (emit 'ldc (pool-string (symbol-name symbol))) 2002 (emit-invokestatic "org/armedbear/lisp/Keyword" 2003 "internKeyword" 2004 "(Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;" 2005 0) 2006 (emit 'putstatic 2007 *this-class* 2008 g 2009 +lisp-symbol+) 1968 (emit-invokestatic "org/armedbear/lisp/Keyword" "internKeyword" 1969 (list +java-string+) +lisp-symbol+) 1970 (emit 'putstatic *this-class* g +lisp-symbol+) 2010 1971 (setf *static-code* *code*) 2011 1972 (setf (gethash symbol *declared-symbols*) g))) … … 2022 1983 (g (gethash symbol *declared-symbols*))) 2023 1984 (cond (g 2024 (emit 'getstatic 2025 *this-class* 2026 g 2027 +lisp-symbol+)) 1985 (emit 'getstatic *this-class* g +lisp-symbol+)) 2028 1986 (t 2029 1987 (emit 'ldc (pool-string (symbol-name symbol))) 2030 1988 (emit 'ldc (pool-string (package-name (symbol-package symbol)))) 2031 (emit-invokestatic +lisp-class+ 2032 "internInPackage" 2033 "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;" 2034 -1))) 1989 (emit-invokestatic +lisp-class+ "internInPackage" 1990 (list +java-string+ +java-string+) 1991 +lisp-symbol+))) 2035 1992 (declare-field f +lisp-object+) 2036 (emit-invokevirtual +lisp-symbol-class+ 2037 "getSymbolFunctionOrDie" 2038 nil 2039 +lisp-object+) 2040 (emit 'putstatic 2041 *this-class* 2042 f 2043 +lisp-object+) 1993 (emit-invokevirtual +lisp-symbol-class+ "getSymbolFunctionOrDie" 1994 nil +lisp-object+) 1995 (emit 'putstatic *this-class* f +lisp-object+) 2044 1996 (setq *static-code* *code*) 2045 1997 (setf (gethash symbol *declared-functions*) f))) … … 2064 2016 (emit 'ldc (pool-string (symbol-name symbol))) 2065 2017 (emit 'ldc (pool-string (package-name (symbol-package symbol)))) 2066 (emit-invokestatic +lisp-class+ 2067 "internInPackage" 2068 "(Ljava/lang/String;Ljava/lang/String;)Lorg/armedbear/lisp/Symbol;" 2069 -1))) 2018 (emit-invokestatic +lisp-class+ "internInPackage" 2019 (list +java-string+ +java-string+) 2020 +lisp-symbol+))) 2070 2021 (declare-field f +lisp-object+) 2071 (emit-invokevirtual +lisp-symbol-class+ 2072 "getSymbolSetfFunctionOrDie" 2073 nil 2074 +lisp-object+) 2075 (emit 'putstatic 2076 *this-class* 2077 f 2078 +lisp-object+) 2022 (emit-invokevirtual +lisp-symbol-class+ "getSymbolSetfFunctionOrDie" 2023 nil +lisp-object+) 2024 (emit 'putstatic *this-class* f +lisp-object+) 2079 2025 (setq *static-code* *code*) 2080 2026 (setf (gethash name *declared-functions*) f)))) … … 2109 2055 (t 2110 2056 (emit 'ldc (pool-int n)))) 2111 (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)2057 (emit-invokespecial-init +lisp-fixnum-class+ '("I")) 2112 2058 (emit 'putstatic *this-class* g +lisp-fixnum+) 2113 2059 (setf *static-code* *code*) … … 2122 2068 (*code* *static-code*)) 2123 2069 (declare-field g +lisp-object+) 2124 (emit 'ldc 2125 (pool-string s)) 2126 (emit-invokestatic +lisp-class+ 2127 "readObjectFromString" 2128 "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;" 2129 0) 2130 (emit 'putstatic 2131 *this-class* 2132 g 2133 +lisp-object+) 2070 (emit 'ldc (pool-string s)) 2071 (emit-invokestatic +lisp-class+ "readObjectFromString" 2072 (list +java-string+) +lisp-object+) 2073 (emit 'putstatic *this-class* g +lisp-object+) 2134 2074 (setf *static-code* *code*) 2135 2075 g)) … … 2142 2082 (*code* *static-code*)) 2143 2083 (declare-field g +lisp-object+) 2144 (emit 'ldc 2145 (pool-string s)) 2146 (emit-invokestatic +lisp-class+ 2147 "readObjectFromString" 2148 "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;" 2149 0) 2150 (emit 'putstatic 2151 *this-class* 2152 g 2153 +lisp-object+) 2084 (emit 'ldc (pool-string s)) 2085 (emit-invokestatic +lisp-class+ "readObjectFromString" 2086 (list +java-string+) +lisp-object+) 2087 (emit 'putstatic *this-class* g +lisp-object+) 2154 2088 (setf *static-code* *code*) 2155 2089 g)) … … 2162 2096 (*code* *static-code*)) 2163 2097 (declare-field g2 +lisp-object+) 2164 (emit 'getstatic 2165 *this-class* 2166 g1 2167 +lisp-string+) 2168 (emit-invokestatic +lisp-class+ 2169 "recall" 2170 "(Lorg/armedbear/lisp/SimpleString;)Lorg/armedbear/lisp/LispObject;" 2171 0) 2172 (emit 'putstatic 2173 *this-class* 2174 g2 2175 +lisp-object+) 2098 (emit 'getstatic *this-class* g1 +lisp-string+) 2099 (emit-invokestatic +lisp-class+ "recall" 2100 (list +lisp-simple-string+) +lisp-object+) 2101 (emit 'putstatic *this-class* g2 +lisp-object+) 2176 2102 (setf *static-code* *code*) 2177 2103 g2))) … … 2186 2112 (emit 'ldc 2187 2113 (pool-string s)) 2188 (emit-invokestatic +lisp-class+ 2189 "readObjectFromString" 2190 "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;" 2191 0) 2192 (emit-invokestatic +lisp-class+ 2193 "coerceToFunction" 2194 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 2195 0) 2196 (emit 'putstatic 2197 *this-class* 2198 g 2199 +lisp-object+) 2114 (emit-invokestatic +lisp-class+ "readObjectFromString" 2115 (list +java-string+) +lisp-object+) 2116 (emit-invokestatic +lisp-class+ "coerceToFunction" 2117 (list +lisp-object+) +lisp-object+) 2118 (emit 'putstatic *this-class* g +lisp-object+) 2200 2119 (setf *static-code* *code*) 2201 2120 g)) … … 2206 2125 (*code* *static-code*)) 2207 2126 (declare-field g +lisp-object+) 2208 (emit 'ldc 2209 (pool-string (file-namestring classfile))) 2210 (emit-invokestatic +lisp-class+ 2211 "loadCompiledFunction" 2212 "(Ljava/lang/String;)Lorg/armedbear/lisp/LispObject;" 2213 0) 2214 (emit 'putstatic 2215 *this-class* 2216 g 2217 +lisp-object+) 2127 (emit 'ldc (pool-string (file-namestring classfile))) 2128 (emit-invokestatic +lisp-class+ "loadCompiledFunction" 2129 (list +java-string+) +lisp-object+) 2130 (emit 'putstatic *this-class* g +lisp-object+) 2218 2131 (setf *static-code* *code*) 2219 2132 g)) … … 2228 2141 (emit 'dup) 2229 2142 (emit 'ldc (pool-string string)) 2230 (emit-invokespecial +lisp-simple-string-class+ 2231 "<init>" 2232 "(Ljava/lang/String;)V" 2233 -2) 2234 (emit 'putstatic 2235 *this-class* 2236 g 2237 +lisp-simple-string+) 2143 (emit-invokespecial-init +lisp-simple-string-class+ (list +java-string+)) 2144 (emit 'putstatic *this-class* g +lisp-simple-string+) 2238 2145 (setf *static-code* *code*) 2239 2146 (setf (gethash string *declared-strings*) g))) … … 2244 2151 (return-from compile-constant)) 2245 2152 (when (eq representation :unboxed-fixnum) 2246 (cond 2247 ((fixnump form) 2248 (emit-push-constant-int form) 2249 (emit-move-from-stack target) 2250 (return-from compile-constant)) 2251 (t 2252 (assert nil)))) 2153 (cond ((fixnump form) 2154 (emit-push-constant-int form) 2155 (emit-move-from-stack target) 2156 (return-from compile-constant)) 2157 (t 2158 (assert nil)))) 2253 2159 (cond ((numberp form) 2254 2160 (if (fixnump form) … … 2261 2167 (translation (cdr (assoc n translations)))) 2262 2168 (if translation 2263 (emit 'getstatic 2264 +lisp-fixnum-class+ 2265 translation 2266 +lisp-fixnum+) 2267 (emit 'getstatic 2268 *this-class* 2269 (declare-fixnum n) 2270 +lisp-fixnum+))) 2271 (emit 'getstatic 2272 *this-class* 2273 (declare-object-as-string form) 2274 +lisp-object+))) 2169 (emit 'getstatic +lisp-fixnum-class+ translation +lisp-fixnum+) 2170 (emit 'getstatic *this-class* (declare-fixnum n) +lisp-fixnum+))) 2171 (emit 'getstatic *this-class* 2172 (declare-object-as-string form) +lisp-object+))) 2275 2173 ((stringp form) 2276 2174 (if *compile-file-truename* 2277 (emit 'getstatic 2278 *this-class* 2279 (declare-string form) 2280 +lisp-simple-string+) 2281 (emit 'getstatic 2282 *this-class* 2283 (declare-object form) 2284 +lisp-object+))) 2175 (emit 'getstatic *this-class* 2176 (declare-string form) +lisp-simple-string+) 2177 (emit 'getstatic *this-class* 2178 (declare-object form) +lisp-object+))) 2285 2179 ((vectorp form) 2286 2180 (if *compile-file-truename* 2287 (emit 'getstatic 2288 *this-class* 2289 (declare-object-as-string form) 2290 +lisp-object+) 2291 (emit 'getstatic 2292 *this-class* 2293 (declare-object form) 2294 +lisp-object+))) 2181 (emit 'getstatic *this-class* 2182 (declare-object-as-string form) +lisp-object+) 2183 (emit 'getstatic *this-class* 2184 (declare-object form) +lisp-object+))) 2295 2185 ((characterp form) 2296 (emit 'getstatic 2297 *this-class* 2298 (declare-object-as-string form) 2299 +lisp-object+)) 2186 (emit 'getstatic *this-class* 2187 (declare-object-as-string form) +lisp-object+)) 2300 2188 ((or (classp form) (hash-table-p form) (typep form 'generic-function)) 2301 (emit 'getstatic 2302 *this-class* 2303 (declare-object form) 2304 +lisp-object+)) 2189 (emit 'getstatic *this-class* 2190 (declare-object form) +lisp-object+)) 2305 2191 ((pathnamep form) 2306 2192 (let ((g (if *compile-file-truename* 2307 2193 (declare-object-as-string form) 2308 2194 (declare-object form)))) 2309 (emit 'getstatic 2310 *this-class* 2311 g 2312 +lisp-object+))) 2195 (emit 'getstatic *this-class* g +lisp-object+))) 2313 2196 ((packagep form) 2314 2197 (let ((g (if *compile-file-truename* 2315 2198 (declare-package form) 2316 2199 (declare-object form)))) 2317 (emit 'getstatic 2318 *this-class* 2319 g 2320 +lisp-object+))) 2200 (emit 'getstatic *this-class* g +lisp-object+))) 2321 2201 (t 2322 2202 (if *compile-file-truename* 2323 2203 (error "COMPILE-CONSTANT unhandled case ~S" form) 2324 (emit 'getstatic 2325 *this-class* 2326 (declare-object form) 2327 +lisp-object+)))) 2204 (emit 'getstatic *this-class* 2205 (declare-object form) +lisp-object+)))) 2328 2206 (emit-move-from-stack target)) 2329 2207 … … 2388 2266 (compile-form arg :target :stack) 2389 2267 (maybe-emit-clear-values arg) 2390 (emit-invokespecial +lisp-cons-class+ 2391 "<init>" 2392 "(Lorg/armedbear/lisp/LispObject;)V" 2393 -2) 2268 (emit-invokespecial-init +lisp-cons-class+ (list +lisp-object+)) 2394 2269 (emit-move-from-stack target) 2395 2270 t) 2396 (t 2397 nil))))) 2271 (t nil))))) 2398 2272 2399 2273 (defparameter binary-operators (make-hash-table :test 'eq)) … … 2464 2338 (single-valued-p second)) 2465 2339 (emit-clear-values)) 2466 (emit-invokestatic +lisp-class+ 2467 "list2" 2468 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;" 2469 -1) 2340 (emit-invokestatic +lisp-class+ "list2" 2341 (list +lisp-object+ +lisp-object+) +lisp-cons+) 2470 2342 (emit-move-from-stack target) 2471 2343 t) … … 2475 2347 (maybe-emit-clear-values first) 2476 2348 (emit 'sipush second) 2477 (emit-invokevirtual +lisp-object-class+ 2478 "getSlotValue" 2479 '("I") 2480 +lisp-object+) 2349 (emit-invokevirtual +lisp-object-class+ "getSlotValue" 2350 '("I") +lisp-object+) 2481 2351 (when (eq representation :unboxed-fixnum) 2482 2352 (emit-unbox-fixnum)) … … 2563 2433 (unless (every 'single-valued-p args) 2564 2434 (emit-clear-values)) 2565 (emit-invokestatic +lisp-class+ 2566 "list3" 2567 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/Cons;" 2568 -2) 2435 (emit-invokestatic +lisp-class+ "list3" 2436 (list +lisp-object+ +lisp-object+ +lisp-object+) 2437 +lisp-cons+) 2569 2438 (emit-move-from-stack target) 2570 2439 t) … … 2576 2445 (compile-form (third args) :target :stack) 2577 2446 (maybe-emit-clear-values (third args)) 2578 (emit-invokevirtual +lisp-object-class+ 2579 "setSlotValue" 2580 (list "I" +lisp-object+) 2581 +lisp-object+) 2447 (emit-invokevirtual +lisp-object-class+ "setSlotValue" 2448 (list "I" +lisp-object+) +lisp-object+) 2582 2449 (emit-move-from-stack target) 2583 2450 t)) … … 3146 3013 3147 3014 (defun compile-multiple-value-list (form &key (target *val*) representation) 3148 ;; Added Dec 9 2004 7:52 PM3149 3015 (emit-clear-values) 3150 3151 3016 (compile-form (second form) :target :stack) 3152 (emit-invokestatic +lisp-class+ 3153 "multipleValueList" 3154 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 3155 0) 3017 (emit-invokestatic +lisp-class+ "multipleValueList" 3018 (list +lisp-object+) +lisp-object+) 3156 3019 (emit-move-from-stack target)) 3157 3020 … … 3161 3024 (result-register (allocate-register)) 3162 3025 (values-register (allocate-register))) 3163 3164 ;; Added Dec 9 2004 3:46 AM3165 3026 ;; Make sure there are no leftover values from previous calls. 3166 3027 (emit-clear-values) 3167 3168 3028 (compile-form first-subform :target result-register) 3169 3029 ;; Save multiple values returned by first subform. … … 3187 3047 (2 3188 3048 (compile-form (second form) :target :stack) 3189 (emit-invokestatic +lisp-class+ 3190 "coerceToFunction" 3191 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 3192 0) 3049 (emit-invokestatic +lisp-class+ "coerceToFunction" 3050 (list +lisp-object+) +lisp-object+) 3193 3051 (emit-invokevirtual +lisp-object-class+ "execute" nil +lisp-object+) 3194 3052 (emit-move-from-stack target)) … … 3200 3058 (emit 'aload function-register) 3201 3059 (emit-push-current-thread) 3202 (emit-invokestatic +lisp-class+ 3203 "multipleValueCall1" 3204 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispThread;)Lorg/armedbear/lisp/LispObject;" 3205 -2) 3060 (emit-invokestatic +lisp-class+ "multipleValueCall1" 3061 (list +lisp-object+ +lisp-object+ +lisp-thread+) 3062 +lisp-object+) 3206 3063 (emit-move-from-stack target))) 3207 3064 (t … … 3211 3068 (values-register (allocate-register))) 3212 3069 (compile-form (second form) :target :stack) 3213 (emit-invokestatic +lisp-class+ 3214 "coerceToFunction" 3215 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 3216 0) 3070 (emit-invokestatic +lisp-class+ "coerceToFunction" 3071 (list +lisp-object+) +lisp-object+) 3217 3072 (emit-move-from-stack function-register) 3218 3073 (emit 'aconst_null) … … 3223 3078 (emit 'swap) 3224 3079 (emit 'aload values-register) 3225 (emit-invokevirtual +lisp-thread-class+ 3226 "accumulateValues" 3080 (emit-invokevirtual +lisp-thread-class+ "accumulateValues" 3227 3081 (list +lisp-object+ +lisp-object-array+) 3228 3082 +lisp-object-array+) … … 3231 3085 (emit 'aload function-register) 3232 3086 (emit 'aload values-register) 3233 (emit-invokevirtual +lisp-object-class+ 3234 "execute" 3235 (list +lisp-object-array+) 3236 +lisp-object+) 3087 (emit-invokevirtual +lisp-object-class+ "execute" 3088 (list +lisp-object-array+) +lisp-object+) 3237 3089 (emit-move-from-stack target))))) 3238 3090 … … 3244 3096 (emit-push-current-thread) 3245 3097 (emit 'swap) 3246 (emit 'getstatic 3247 *this-class* 3248 (declare-symbol (variable-name variable)) 3249 +lisp-symbol+) 3098 (emit 'getstatic *this-class* 3099 (declare-symbol (variable-name variable)) +lisp-symbol+) 3250 3100 (emit 'swap) 3251 (emit-invokevirtual +lisp-thread-class+ 3252 "bindSpecial" 3253 (list +lisp-symbol+ +lisp-object+) 3254 nil)) 3101 (emit-invokevirtual +lisp-thread-class+ "bindSpecial" 3102 (list +lisp-symbol+ +lisp-object+) nil)) 3255 3103 ((variable-closure-index variable) 3256 3104 (emit 'aload (compiland-closure-register *current-compiland*)) … … 3276 3124 (setf bind-special-p t)) 3277 3125 (t 3278 ;; (setf (variable-index variable) (length (context-vars *context*)))3279 3126 (unless (variable-closure-index variable) 3280 (setf (variable-register variable) (allocate-register))) 3281 ;; (add-variable-to-context variable) 3282 )))) 3127 (setf (variable-register variable) (allocate-register))))))) 3283 3128 ;; If we're going to bind any special variables... 3284 3129 (when bind-special-p … … 3288 3133 (emit 'getfield +lisp-thread-class+ "lastSpecialBinding" +lisp-binding+) 3289 3134 (emit 'astore (block-environment-register block))) 3290 3291 ;; Added Dec 9 2004 3:46 AM3292 3135 ;; Make sure there are no leftover values from previous calls. 3293 3136 (emit-clear-values) 3294 3295 3137 ;; Bind the variables. 3296 3138 (aver (= (length vars) (length variables))) … … 3328 3170 (emit 'aload result-register) 3329 3171 (emit 'bipush (length vars)) 3330 (emit-invokevirtual +lisp-thread-class+ 3331 "getValues" 3332 (list +lisp-object+ "I") 3333 +lisp-object-array+) 3172 (emit-invokevirtual +lisp-thread-class+ "getValues" 3173 (list +lisp-object+ "I") +lisp-object-array+) 3334 3174 ;; Values array is now on the stack at runtime. 3335 3175 (label LABEL2) … … 3674 3514 (emit 'dup) 3675 3515 (compile-form `',(tag-label tag) :target :stack) ; Tag. 3676 (emit-invokespecial +lisp-go-class+ 3677 "<init>" 3678 "(Lorg/armedbear/lisp/LispObject;)V" 3679 -2) 3516 (emit-invokespecial-init +lisp-go-class+ (list +lisp-object+)) 3680 3517 (emit 'athrow) 3681 3518 ;; Following code will not be reached, but is needed for JVM stack … … 3822 3659 (compile-form `',(block-catch-tag block) :target :stack) ; Tag. 3823 3660 (emit 'aload temp-register)))) 3824 (emit-invokespecial +lisp-return-class+ 3825 "<init>" 3826 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V" 3827 -3) 3661 (emit-invokespecial-init +lisp-return-class+ (list +lisp-object+ +lisp-object+)) 3828 3662 (emit 'athrow) 3829 3663 ;; Following code will not be reached, but is needed for JVM stack … … 3840 3674 (emit 'dup) 3841 3675 (process-args (cdr form)) 3842 (emit-invokespecial "org/armedbear/lisp/Cons" 3843 "<init>" 3844 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V" 3845 -3) 3676 (emit-invokespecial-init +lisp-cons-class+ (list +lisp-object+ +lisp-object+)) 3846 3677 (emit-move-from-stack target)) 3847 3678 … … 4082 3913 ((compiland-closure-register *current-compiland*) 4083 3914 (emit 'aload (compiland-closure-register *current-compiland*)) 4084 (emit-invokestatic +lisp-class+ 4085 "makeCompiledClosure" 4086 ;; "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 4087 (make-descriptor (list +lisp-object+ +lisp-object-array+) 4088 +lisp-object+) 4089 -1) 4090 (emit 'checkcast "org/armedbear/lisp/CompiledClosure") 4091 ) ; Stack: compiled-closure 3915 (emit-invokestatic +lisp-class+ "makeCompiledClosure" 3916 (list +lisp-object+ +lisp-object-array+) +lisp-object+) 3917 (emit 'checkcast "org/armedbear/lisp/CompiledClosure")) ; Stack: compiled-closure 4092 3918 (t 4093 3919 ;; Shouldn't happen. 4094 3920 (aver (progn 'unexpected nil)) 4095 3921 (emit-push-constant-int 0) 4096 (emit 'anewarray "org/armedbear/lisp/LispObject")))3922 (emit 'anewarray +lisp-object-class+))) 4097 3923 (emit-move-from-stack target))) 4098 3924 … … 4114 3940 (declare-local-function local-function) 4115 3941 (declare-object (local-function-function local-function))))) 4116 (emit 'getstatic 4117 *this-class* 4118 g 4119 +lisp-object+)))) ; Stack: template-function 3942 (emit 'getstatic *this-class* 3943 g +lisp-object+)))) ; Stack: template-function 4120 3944 (cond ((null *closure-variables*)) ; Nothing to do. 4121 3945 ((compiland-closure-register *current-compiland*) 4122 3946 (dformat t "p2-function 3~%") 4123 3947 (emit 'aload (compiland-closure-register *current-compiland*)) 4124 (emit-invokestatic +lisp-class+ 4125 "makeCompiledClosure" 4126 "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 4127 -1)) ; Stack: compiled-closure 3948 (emit-invokestatic +lisp-class+ "makeCompiledClosure" 3949 (list +lisp-object+ +lisp-object-array+) 3950 +lisp-object+)) ; Stack: compiled-closure 4128 3951 (t 4129 3952 (aver (progn 'unexpected nil)))) 4130 3953 (emit-move-from-stack target)) 4131 3954 ((inline-ok name) 4132 (emit 'getstatic 4133 *this-class* 4134 (declare-function name) 4135 +lisp-object+) 3955 (emit 'getstatic *this-class* 3956 (declare-function name) +lisp-object+) 4136 3957 (emit-move-from-stack target)) 4137 3958 (t 4138 (emit 'getstatic 4139 *this-class* 4140 (declare-symbol name) 4141 +lisp-symbol+) 4142 (emit-invokevirtual +lisp-object-class+ 4143 "getSymbolFunctionOrDie" 4144 nil 4145 +lisp-object+) 3959 (emit 'getstatic *this-class* 3960 (declare-symbol name) +lisp-symbol+) 3961 (emit-invokevirtual +lisp-object-class+ "getSymbolFunctionOrDie" 3962 nil +lisp-object+) 4146 3963 (emit-move-from-stack target)))) 4147 3964 ((and (consp name) (eq (car name) 'SETF)) 4148 3965 ; FIXME Need to check for NOTINLINE declaration! 4149 3966 (cond ((member name *toplevel-defuns* :test #'equal) 4150 (emit 'getstatic 4151 *this-class* 4152 (declare-setf-function name) 4153 +lisp-object+) 3967 (emit 'getstatic *this-class* 3968 (declare-setf-function name) +lisp-object+) 4154 3969 (emit-move-from-stack target)) 4155 3970 ((and (null *compile-file-truename*) 4156 3971 (fdefinition name)) 4157 (emit 'getstatic 4158 *this-class* 4159 (declare-object (fdefinition name)) 4160 +lisp-object+) 3972 (emit 'getstatic *this-class* 3973 (declare-object (fdefinition name)) +lisp-object+) 4161 3974 (emit-move-from-stack target)) 4162 3975 (t 4163 (emit 'getstatic 4164 *this-class* 4165 (declare-symbol (cadr name)) 4166 +lisp-symbol+) 3976 (emit 'getstatic *this-class* 3977 (declare-symbol (cadr name)) +lisp-symbol+) 4167 3978 (emit-invokevirtual +lisp-symbol-class+ 4168 3979 "getSymbolSetfFunctionOrDie" 4169 nil 4170 +lisp-object+) 3980 nil +lisp-object+) 4171 3981 (emit-move-from-stack target)))) 4172 3982 ((compiland-p name) … … 4186 3996 (var1 (unboxed-fixnum-variable arg1)) 4187 3997 (var2 (unboxed-fixnum-variable arg2))) 4188 (cond 4189 ((and (numberp arg1) (numberp arg2)) 4190 (dformat t "p2-ash case 1~%") 4191 (compile-constant (ash arg1 arg2) 4192 :target target 4193 :representation representation)) 4194 ((and var1 (fixnump arg2) (< 0 arg2 32)) 4195 (dformat t "p2-ash case 2~%") 4196 (case representation 4197 (:unboxed-fixnum 4198 (emit-push-int var1) 4199 (emit-push-constant-int arg2) 4200 (emit 'ishl)) 4201 (t 4202 (emit-push-int var1) 4203 (emit 'i2l) 4204 (emit-push-constant-int arg2) 4205 (emit 'lshl) 4206 (emit-box-long))) 4207 (emit-move-from-stack target representation)) 4208 ((and var1 (fixnump arg2) (< -32 arg2 0)) 4209 (dformat t "p2-ash case 3~%") 4210 (unless (eq representation :unboxed-fixnum) 4211 (emit 'new +lisp-fixnum-class+) 4212 (emit 'dup)) 4213 (emit-push-int var1) 4214 (emit-push-constant-int (- arg2)) 4215 (emit 'ishr) 4216 (unless (eq representation :unboxed-fixnum) 4217 (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)) 4218 (emit-move-from-stack target representation)) 4219 (var2 4220 (dformat t "p2-ash case 4~%") 4221 (compile-form arg1 :target :stack) 4222 (maybe-emit-clear-values arg1) 4223 (emit 'iload (variable-register var2)) 4224 (emit-invokevirtual +lisp-object-class+ "ash" '("I") +lisp-object+) 4225 (when (eq representation :unboxed-fixnum) 4226 (emit-unbox-fixnum)) 4227 (emit-move-from-stack target representation)) 4228 ((fixnump arg2) 4229 (dformat t "p2-ash case 5~%") 4230 (compile-form arg1 :target :stack) 4231 (maybe-emit-clear-values arg1) 4232 (emit-push-constant-int arg2) 4233 (emit-invokevirtual +lisp-object-class+ "ash" '("I") +lisp-object+) 4234 (when (eq representation :unboxed-fixnum) 4235 (emit-unbox-fixnum)) 4236 (emit-move-from-stack target representation)) 4237 (t 4238 (dformat t "p2-ash case 6~%") 4239 (compile-function-call form target representation))))) 3998 (cond ((and (numberp arg1) (numberp arg2)) 3999 (dformat t "p2-ash case 1~%") 4000 (compile-constant (ash arg1 arg2) 4001 :target target 4002 :representation representation)) 4003 ((and var1 (fixnump arg2) (< 0 arg2 32)) 4004 (dformat t "p2-ash case 2~%") 4005 (case representation 4006 (:unboxed-fixnum 4007 (emit-push-int var1) 4008 (emit-push-constant-int arg2) 4009 (emit 'ishl)) 4010 (t 4011 (emit-push-int var1) 4012 (emit 'i2l) 4013 (emit-push-constant-int arg2) 4014 (emit 'lshl) 4015 (emit-box-long))) 4016 (emit-move-from-stack target representation)) 4017 ((and var1 (fixnump arg2) (< -32 arg2 0)) 4018 (dformat t "p2-ash case 3~%") 4019 (unless (eq representation :unboxed-fixnum) 4020 (emit 'new +lisp-fixnum-class+) 4021 (emit 'dup)) 4022 (emit-push-int var1) 4023 (emit-push-constant-int (- arg2)) 4024 (emit 'ishr) 4025 (unless (eq representation :unboxed-fixnum) 4026 (emit-invokespecial-init +lisp-fixnum-class+ '("I"))) 4027 (emit-move-from-stack target representation)) 4028 (var2 4029 (dformat t "p2-ash case 4~%") 4030 (compile-form arg1 :target :stack) 4031 (maybe-emit-clear-values arg1) 4032 (emit 'iload (variable-register var2)) 4033 (emit-invokevirtual +lisp-object-class+ "ash" '("I") +lisp-object+) 4034 (when (eq representation :unboxed-fixnum) 4035 (emit-unbox-fixnum)) 4036 (emit-move-from-stack target representation)) 4037 ((fixnump arg2) 4038 (dformat t "p2-ash case 5~%") 4039 (compile-form arg1 :target :stack) 4040 (maybe-emit-clear-values arg1) 4041 (emit-push-constant-int arg2) 4042 (emit-invokevirtual +lisp-object-class+ "ash" '("I") +lisp-object+) 4043 (when (eq representation :unboxed-fixnum) 4044 (emit-unbox-fixnum)) 4045 (emit-move-from-stack target representation)) 4046 (t (dformat t "p2-ash case 6~%") 4047 (compile-function-call form target representation))))) 4240 4048 4241 4049 (defun p2-logand (form &key (target *val*) representation) … … 4248 4056 (dformat t "p2-logand var1 = ~S~%" var1) 4249 4057 (dformat t "p2-logand type-of arg2 is ~S~%" (type-of arg2)) 4250 (cond 4251 ((and (integerp arg1) (integerp arg2)) 4252 (dformat t "p2-logand case 1~%") 4253 (compile-constant (logand arg1 arg2) :target target :representation representation) 4254 (return-from p2-logand t)) 4255 ((and (fixnump arg2) (zerop arg2)) 4256 (dformat t "p2-logand case 2~%") 4257 (compile-constant 0 :target target :representation representation) 4258 (return-from p2-logand t)) 4259 ((and var1 (fixnump arg2)) 4260 (dformat t "p2-logand case 3~%") 4261 (unless (eq representation :unboxed-fixnum) 4262 (emit 'new +lisp-fixnum-class+) 4263 (emit 'dup)) 4264 (emit 'iload (variable-register var1)) 4265 (emit-push-constant-int arg2) 4266 (emit 'iand) 4267 (unless (eq representation :unboxed-fixnum) 4268 (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)) 4269 (emit-move-from-stack target representation) 4270 (return-from p2-logand t)) 4271 ((fixnump arg2) 4272 (dformat t "p2-logand case 4~%") 4273 (let ((type (derive-type arg1))) 4274 (dformat t "p2-logand arg1 derived type = ~S~%" type) 4275 (cond 4276 ((subtypep type 'fixnum) 4277 (dformat t "p2-logand case 4a~%") 4278 (unless (eq representation :unboxed-fixnum) 4279 (emit 'new +lisp-fixnum-class+) 4280 (emit 'dup)) 4281 (compile-form arg1 :target :stack :representation :unboxed-fixnum) 4282 (maybe-emit-clear-values arg1) 4283 (emit-push-constant-int arg2) 4284 (emit 'iand) 4285 (unless (eq representation :unboxed-fixnum) 4286 (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)) 4287 (emit-move-from-stack target representation)) 4288 (t 4289 (dformat t "p2-logand case 4b~%") 4290 (compile-form arg1 :target :stack) 4291 (maybe-emit-clear-values arg1) 4292 (emit-push-constant-int arg2) 4293 (emit-invokevirtual +lisp-object-class+ "logand" '("I") +lisp-object+) 4294 (when (eq representation :unboxed-fixnum) 4295 (emit-unbox-fixnum)) 4296 (emit-move-from-stack target representation)))) 4297 (return-from p2-logand t)))))) 4058 (cond ((and (integerp arg1) (integerp arg2)) 4059 (dformat t "p2-logand case 1~%") 4060 (compile-constant (logand arg1 arg2) :target target :representation representation) 4061 (return-from p2-logand t)) 4062 ((and (fixnump arg2) (zerop arg2)) 4063 (dformat t "p2-logand case 2~%") 4064 (compile-constant 0 :target target :representation representation) 4065 (return-from p2-logand t)) 4066 ((and var1 (fixnump arg2)) 4067 (dformat t "p2-logand case 3~%") 4068 (unless (eq representation :unboxed-fixnum) 4069 (emit 'new +lisp-fixnum-class+) 4070 (emit 'dup)) 4071 (emit 'iload (variable-register var1)) 4072 (emit-push-constant-int arg2) 4073 (emit 'iand) 4074 (unless (eq representation :unboxed-fixnum) 4075 (emit-invokespecial-init +lisp-fixnum-class+ '("I"))) 4076 (emit-move-from-stack target representation) 4077 (return-from p2-logand t)) 4078 ((fixnump arg2) 4079 (dformat t "p2-logand case 4~%") 4080 (let ((type (derive-type arg1))) 4081 (dformat t "p2-logand arg1 derived type = ~S~%" type) 4082 (cond ((subtypep type 'fixnum) 4083 (dformat t "p2-logand case 4a~%") 4084 (unless (eq representation :unboxed-fixnum) 4085 (emit 'new +lisp-fixnum-class+) 4086 (emit 'dup)) 4087 (compile-form arg1 :target :stack :representation :unboxed-fixnum) 4088 (maybe-emit-clear-values arg1) 4089 (emit-push-constant-int arg2) 4090 (emit 'iand) 4091 (unless (eq representation :unboxed-fixnum) 4092 (emit-invokespecial-init +lisp-fixnum-class+ '("I"))) 4093 (emit-move-from-stack target representation)) 4094 (t (dformat t "p2-logand case 4b~%") 4095 (compile-form arg1 :target :stack) 4096 (maybe-emit-clear-values arg1) 4097 (emit-push-constant-int arg2) 4098 (emit-invokevirtual +lisp-object-class+ "logand" '("I") +lisp-object+) 4099 (when (eq representation :unboxed-fixnum) 4100 (emit-unbox-fixnum)) 4101 (emit-move-from-stack target representation)))) 4102 (return-from p2-logand t)))))) 4298 4103 (dformat t "p2-logand default case~%") 4299 4104 (compile-function-call form target representation)) 4300 4105 4301 4106 (defun derive-type (form) 4302 (cond 4303 ((fixnump form) 4304 (return-from derive-type 'fixnum)) 4305 ((unboxed-fixnum-variable form) 4306 (return-from derive-type 'fixnum)) 4307 ((consp form) 4308 (let ((op (first form))) 4309 (case op 4310 (ASH 4311 (dformat t "derive-type ASH case form = ~S~%" form) 4312 (let* ((arg1 (second form)) 4313 (var1 (unboxed-fixnum-variable arg1)) 4314 (arg2 (third form))) 4315 (dformat t "derive-type ASH case var1 = ~S~%" var1) 4316 (when (and var1 (fixnump arg2) (minusp arg2)) 4317 (return-from derive-type 'FIXNUM)))) 4318 (THE 4319 (dformat t "derive-type THE case form = ~S~%" form) 4320 (when (subtypep (second form) 'FIXNUM) 4321 (dformat t "derive-type THE case form = ~S returning FIXNUM~%" form) 4322 (return-from derive-type 'FIXNUM))))))) 4107 (cond ((fixnump form) 4108 (return-from derive-type 'fixnum)) 4109 ((unboxed-fixnum-variable form) 4110 (return-from derive-type 'fixnum)) 4111 ((consp form) 4112 (let ((op (first form))) 4113 (case op 4114 (ASH 4115 (dformat t "derive-type ASH case form = ~S~%" form) 4116 (let* ((arg1 (second form)) 4117 (var1 (unboxed-fixnum-variable arg1)) 4118 (arg2 (third form))) 4119 (dformat t "derive-type ASH case var1 = ~S~%" var1) 4120 (when (and var1 (fixnump arg2) (minusp arg2)) 4121 (return-from derive-type 'FIXNUM)))) 4122 (THE 4123 (dformat t "derive-type THE case form = ~S~%" form) 4124 (when (subtypep (second form) 'FIXNUM) 4125 (dformat t "derive-type THE case form = ~S returning FIXNUM~%" form) 4126 (return-from derive-type 'FIXNUM))))))) 4323 4127 t) 4324 4128 … … 4328 4132 (compile-form arg :target :stack) 4329 4133 (maybe-emit-clear-values arg) 4330 (cond 4331 ((eq representation :unboxed-fixnum) 4332 (emit-invokevirtual +lisp-object-class+ "length" nil "I")) 4333 (t 4334 (emit-invokevirtual +lisp-object-class+ "LENGTH" nil +lisp-object+))) 4134 (cond ((eq representation :unboxed-fixnum) 4135 (emit-invokevirtual +lisp-object-class+ "length" nil "I")) 4136 (t 4137 (emit-invokevirtual +lisp-object-class+ "LENGTH" nil +lisp-object+))) 4335 4138 (emit-move-from-stack target representation))) 4336 4139 … … 4668 4471 (dformat t "compile-variable-reference ~S~%" name) 4669 4472 (let ((variable (find-visible-variable name))) 4670 (cond 4671 ((null variable) 4672 (when (and (special-variable-p name) 4673 (constantp name)) 4674 (let ((value (symbol-value name))) 4675 (when (or (null *compile-file-truename*) 4676 ;; FIXME File compilation doesn't support all constant 4677 ;; types yet. 4678 (stringp value) 4679 (numberp value) 4680 (packagep value)) 4681 (compile-constant value :target target :representation representation) 4682 (return-from compile-variable-reference)))) 4683 (unless (special-variable-p name) 4684 (unless (memq name *undefined-variables*) 4685 (compiler-warn "Undefined variable ~S" name) 4686 (push name *undefined-variables*))) 4687 (compile-special-reference name target representation)) 4688 ((eq (variable-representation variable) :unboxed-fixnum) 4689 (dformat t "compile-variable-reference unboxed-fixnum case~%") 4690 (cond 4691 ((eq representation :unboxed-fixnum) 4692 (aver (variable-register variable)) 4693 (emit 'iload (variable-register variable))) 4694 (t 4695 (dformat t "compile-variable-reference constructing boxed fixnum for ~S~%" 4696 name) 4697 (emit 'new +lisp-fixnum-class+) 4698 (emit 'dup) 4699 (aver (variable-register variable)) 4700 (emit 'iload (variable-register variable)) 4701 (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2))) 4702 (emit-move-from-stack target representation)) 4703 (t 4704 ;; (dformat t "compile-variable-reference name = ~S representation = ~S~%" 4705 ;; name representation) 4706 (dformat t "compile-variable-reference ~S closure index = ~S~%" 4707 name (variable-closure-index variable)) 4708 (emit 'var-ref variable target representation))))) 4473 (cond ((null variable) 4474 (when (and (special-variable-p name) 4475 (constantp name)) 4476 (let ((value (symbol-value name))) 4477 (when (or (null *compile-file-truename*) 4478 ;; FIXME File compilation doesn't support all constant 4479 ;; types yet. 4480 (stringp value) 4481 (numberp value) 4482 (packagep value)) 4483 (compile-constant value :target target :representation representation) 4484 (return-from compile-variable-reference)))) 4485 (unless (special-variable-p name) 4486 (unless (memq name *undefined-variables*) 4487 (compiler-warn "Undefined variable ~S" name) 4488 (push name *undefined-variables*))) 4489 (compile-special-reference name target representation)) 4490 ((eq (variable-representation variable) :unboxed-fixnum) 4491 (dformat t "compile-variable-reference unboxed-fixnum case~%") 4492 (cond ((eq representation :unboxed-fixnum) 4493 (aver (variable-register variable)) 4494 (emit 'iload (variable-register variable))) 4495 (t (dformat t "compile-variable-reference constructing boxed fixnum for ~S~%" 4496 name) 4497 (emit 'new +lisp-fixnum-class+) 4498 (emit 'dup) 4499 (aver (variable-register variable)) 4500 (emit 'iload (variable-register variable)) 4501 (emit-invokespecial-init +lisp-fixnum-class+ '("I")))) 4502 (emit-move-from-stack target representation)) 4503 (t (dformat t "compile-variable-reference ~S closure index = ~S~%" 4504 name (variable-closure-index variable)) 4505 (emit 'var-ref variable target representation))))) 4709 4506 4710 4507 (defun rewrite-setq (form) … … 4732 4529 (let ((new-form (rewrite-setq form))) 4733 4530 (when (neq new-form form) 4734 (return-from compile-setq (compile-form (p1 new-form) :target target)))) 4531 (return-from compile-setq 4532 (compile-form (p1 new-form) :target target)))) 4735 4533 (emit-push-current-thread) 4736 (emit 'getstatic 4737 *this-class* 4738 (declare-symbol name) 4739 +lisp-symbol+) 4534 (emit 'getstatic *this-class* (declare-symbol name) +lisp-symbol+) 4740 4535 (compile-form value-form :target :stack) 4741 4536 (maybe-emit-clear-values value-form) 4742 (emit-invokevirtual +lisp-thread-class+ 4743 "setSpecialVariable" 4744 (list +lisp-symbol+ +lisp-object+) 4745 +lisp-object+) 4537 (emit-invokevirtual +lisp-thread-class+ "setSpecialVariable" 4538 (list +lisp-symbol+ +lisp-object+) +lisp-object+) 4746 4539 (emit-move-from-stack target)) 4747 4540 ((and (eq (variable-representation variable) :unboxed-fixnum) … … 4758 4551 (aver (variable-register variable)) 4759 4552 (emit 'iload (variable-register variable)) 4760 (emit-invokespecial +lisp-fixnum-class+ "<init>" "(I)V" -2)4553 (emit-invokespecial-init +lisp-fixnum-class+ '("I")) 4761 4554 (emit-move-from-stack target))) 4762 4555 ((eq (variable-representation variable) :unboxed-fixnum) 4763 (dformat t "compile-setq unboxed-fixnum case value-form = ~S~%" value-form) 4556 (dformat t "compile-setq unboxed-fixnum case value-form = ~S~%" 4557 value-form) 4764 4558 (compile-form value-form :target :stack) 4765 4559 (maybe-emit-clear-values value-form) … … 4769 4563 (emit 'istore (variable-register variable)) 4770 4564 (when target 4771 (emit-move-from-stack target)) 4772 ) 4773 (t 4774 (compile-form value-form :target :stack) 4775 (maybe-emit-clear-values value-form) 4776 (when target 4777 (emit 'dup)) 4778 (emit 'var-set variable) 4779 (when target 4780 (when (eq representation :unboxed-fixnum) 4781 (emit-unbox-fixnum)) 4782 (emit-move-from-stack target)))))) 4565 (emit-move-from-stack target))) 4566 (t (compile-form value-form :target :stack) 4567 (maybe-emit-clear-values value-form) 4568 (when target 4569 (emit 'dup)) 4570 (emit 'var-set variable) 4571 (when target 4572 (when (eq representation :unboxed-fixnum) 4573 (emit-unbox-fixnum)) 4574 (emit-move-from-stack target)))))) 4783 4575 4784 4576 (defun p2-the (form &key (target *val*) representation) … … 4820 4612 (emit 'if_acmpne label4) ; Stack depth is 1. 4821 4613 (emit 'aload *thread*) 4822 (emit-invokevirtual +lisp-throw-class+ 4823 "getResult" 4824 (list +lisp-thread+) 4825 +lisp-object+) 4614 (emit-invokevirtual +lisp-throw-class+ "getResult" 4615 (list +lisp-thread+) +lisp-object+) 4826 4616 (emit-move-from-stack target) ; Stack depth is 0. 4827 4617 (emit 'goto label5) … … 4879 4669 (emit-clear-values) ; Do this unconditionally! (MISC.503) 4880 4670 (compile-form (third form) :target :stack) ; Result. 4881 (emit-invokevirtual +lisp-thread-class+ 4882 "throwToTag" 4883 (list +lisp-object+ +lisp-object+) 4884 nil) 4671 (emit-invokevirtual +lisp-thread-class+ "throwToTag" 4672 (list +lisp-object+ +lisp-object+) nil) 4885 4673 ;; Following code will not be reached. 4886 4674 (when target … … 4980 4768 (emit-move-from-stack target)) 4981 4769 ((keywordp form) 4982 (emit 'getstatic 4983 *this-class* 4984 (declare-keyword form) 4985 +lisp-symbol+) 4770 (emit 'getstatic *this-class* (declare-keyword form) +lisp-symbol+) 4986 4771 (emit-move-from-stack target)) 4987 4772 (t … … 5003 4788 (p2-block-node form target)))) 5004 4789 ((constantp form) 5005 ;; (dformat t "compile-form constantp case~%")5006 4790 (compile-constant form :target target :representation representation)) 5007 4791 (t … … 5060 4844 (make-descriptor (list +lisp-object-array+) +lisp-object+))))) 5061 4845 5062 (defun write-class-file (args bodyexecute-method classfile)4846 (defun write-class-file (args execute-method classfile) 5063 4847 (dformat t "write-class-file ~S~%" classfile) 5064 4848 (let* ((super (cond (*child-p* 5065 4849 (if *closure-variables* 5066 "org/armedbear/lisp/ClosureTemplateFunction"4850 +lisp-ctf-class+ 5067 4851 (if *hairy-arglist-p* 5068 4852 +lisp-compiled-function-class+ 5069 4853 +lisp-primitive-class+))) 5070 (*hairy-arglist-p* +lisp-compiled-function-class+) 5071 (t +lisp-primitive-class+))) 4854 (*hairy-arglist-p* 4855 +lisp-compiled-function-class+) 4856 (t 4857 +lisp-primitive-class+))) 5072 4858 (this-index (pool-class *this-class*)) 5073 4859 (super-index (pool-class super)) 5074 4860 (constructor (make-constructor super 5075 4861 (compiland-name *current-compiland*) 5076 args 5077 body))) 4862 args))) 5078 4863 (pool-name "Code") ; Must be in pool! 5079 4864 … … 5419 5204 (cond ((or (memq '&OPTIONAL args) (memq '&KEY args)) 5420 5205 (emit 'iconst_0) 5421 (emit-invokevirtual *this-class* 5422 "processArgs" 5206 (emit-invokevirtual *this-class* "processArgs" 5423 5207 (list +lisp-object-array+ "I") 5424 5208 +lisp-object-array+)) 5425 5209 (t 5426 (emit-invokevirtual *this-class* 5427 "fastProcessArgs" 5210 (emit-invokevirtual *this-class* "fastProcessArgs" 5428 5211 (list +lisp-object-array+) 5429 5212 +lisp-object-array+))) … … 5456 5239 (setf (method-max-locals execute-method) *registers-allocated*) 5457 5240 (setf (method-handlers execute-method) (nreverse *handlers*)) 5458 (write-class-file args bodyexecute-method classfile)5241 (write-class-file args execute-method classfile) 5459 5242 (dformat t "leaving p2-compiland ~S~%" (compiland-name compiland)) 5460 5243 classfile)) … … 5496 5279 (unless (or (null environment) (sys::empty-environment-p environment)) 5497 5280 (error "COMPILE-DEFUN: unable to compile LAMBDA form defined in non-null lexical environment.")) 5498 ;; (setf *child-count* 0)5499 5281 (aver (null *current-compiland*)) 5500 5282 (handler-bind ((warning #'handle-warning)) 5501 ;; (let ((precompiled-form (if *current-compiland*5502 ;; form5503 ;; (precompile-form form t))))5504 5283 (compile-1 (make-compiland :name name 5505 ;; :lambda-expression precompiled-form5506 5284 :lambda-expression (precompile-form form t) 5507 5285 :classfile classfile
Note: See TracChangeset
for help on using the changeset viewer.