Changeset 8377
- Timestamp:
- 01/20/05 20:10:23 (16 years ago)
- File:
-
- 1 edited
-
trunk/j/src/org/armedbear/lisp/jvm.lisp (modified) (55 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/j/src/org/armedbear/lisp/jvm.lisp
r8376 r8377 2 2 ;;; 3 3 ;;; Copyright (C) 2003-2005 Peter Graves 4 ;;; $Id: jvm.lisp,v 1.3 59 2005-01-20 17:09:07piso Exp $4 ;;; $Id: jvm.lisp,v 1.360 2005-01-20 20:10:23 piso Exp $ 5 5 ;;; 6 6 ;;; This program is free software; you can redistribute it and/or … … 65 65 (precompile-form (list* 'LAMBDA ',lambda-list ',body) t)) 66 66 ',name)) 67 67 68 #+nil 68 69 (defmacro defsubst (&rest args) … … 915 916 (setf (instruction-stack instruction) stack))) 916 917 917 (defun emit-invokevirtual (class-name method-name descriptor stack) 918 (let ((instruction (emit 'invokevirtual 919 class-name method-name (descriptor descriptor)))) 918 ;; (defun emit-invokevirtual (class-name method-name descriptor stack) 919 ;; (let ((instruction (emit 'invokevirtual 920 ;; class-name method-name (descriptor descriptor)))) 921 ;; (setf (instruction-stack instruction) stack))) 922 923 (defun emit-invokevirtual-2 (class-name method-name arg-types return-type) 924 (let* ((descriptor (make-descriptor arg-types return-type)) 925 (stack (- (if return-type 1 0) 1 (length arg-types))) 926 (instruction (emit 'invokevirtual class-name method-name descriptor))) 920 927 (setf (instruction-stack instruction) stack))) 921 928 … … 953 960 (emit 'if_icmpeq `,label1) 954 961 (emit 'aload 0) ; this 955 (emit-invokevirtual *this-class* 956 "argCountError" 957 "()V" 958 -1) 962 (emit-invokevirtual-2 *this-class* "argCountError" nil nil) 959 963 (emit 'label `,label1)))) 960 964 … … 1136 1140 ;; Expects value on stack. 1137 1141 (defun emit-invoke-method (method-name target representation) 1138 (emit-invokevirtual +lisp-object-class+1139 method-name1140 "()Lorg/armedbear/lisp/LispObject;"1141 0)1142 (emit-invokevirtual-2 +lisp-object-class+ 1143 method-name 1144 nil 1145 +lisp-object+) 1142 1146 (when (eq representation :unboxed-fixnum) 1143 1147 (emit-unbox-fixnum)) … … 1854 1858 "<init>" 1855 1859 ;; "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/Environment;)V" 1856 `((,+lisp-symbol+ ,+lisp-object+ ,+lisp-object+ ,+lisp-environment+) nil) 1860 ;; `((,+lisp-symbol+ ,+lisp-object+ ,+lisp-object+ ,+lisp-environment+) nil) 1861 (make-descriptor (list +lisp-symbol+ +lisp-object+ +lisp-object+ +lisp-environment+) 1862 nil) 1857 1863 -5)) 1858 1864 (*child-p* … … 2030 2036 -1))) 2031 2037 (declare-field f +lisp-object+) 2032 (emit-invokevirtual +lisp-symbol-class+ 2033 "getSymbolFunctionOrDie" 2034 "()Lorg/armedbear/lisp/LispObject;" 2035 0) 2038 (emit-invokevirtual-2 +lisp-symbol-class+ 2039 "getSymbolFunctionOrDie" 2040 ;; "()Lorg/armedbear/lisp/LispObject;" 2041 ;; 0) 2042 nil 2043 +lisp-object+) 2036 2044 (emit 'putstatic 2037 2045 *this-class* … … 2065 2073 -1))) 2066 2074 (declare-field f +lisp-object+) 2067 (emit-invokevirtual +lisp-symbol-class+ 2068 "getSymbolSetfFunctionOrDie" 2069 "()Lorg/armedbear/lisp/LispObject;" 2070 0) 2075 (emit-invokevirtual-2 +lisp-symbol-class+ 2076 "getSymbolSetfFunctionOrDie" 2077 ;; "()Lorg/armedbear/lisp/LispObject;" 2078 ;; 0) 2079 nil 2080 +lisp-object+) 2071 2081 (emit 'putstatic 2072 2082 *this-class* … … 2426 2436 2427 2437 (defun compile-binary-operation (op args target representation) 2428 ;; (dformat t "compile-binary-operation op = ~S representation = ~S~%"2429 ;; op representation)2430 2438 (compile-form (first args) :target :stack) 2431 2439 (compile-form (second args) :target :stack) … … 2433 2441 (single-valued-p (second args))) 2434 2442 (emit-clear-values)) 2435 (emit-invokevirtual +lisp-object-class+2436 op2437 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"2438 -1)2443 (emit-invokevirtual-2 +lisp-object-class+ 2444 op 2445 (list +lisp-object+) 2446 +lisp-object+) 2439 2447 (when (eq representation :unboxed-fixnum) 2440 2448 (emit-unbox-fixnum)) … … 2481 2489 (maybe-emit-clear-values first) 2482 2490 (emit 'sipush second) 2483 (emit-invokevirtual +lisp-object-class+2484 "getSlotValue"2485 "(I)Lorg/armedbear/lisp/LispObject;"2486 -1)2491 (emit-invokevirtual-2 +lisp-object-class+ 2492 "getSlotValue" 2493 (list "I") 2494 +lisp-object+) 2487 2495 (when (eq representation :unboxed-fixnum) 2488 2496 (emit-unbox-fixnum)) … … 2532 2540 (maybe-emit-clear-values arg2) 2533 2541 (emit 'swap) 2534 (emit-invokevirtual +lisp-object-class+ 2535 "eql" 2536 "(I)Z" 2537 -1) 2542 (emit-invokevirtual-2 +lisp-object-class+ 2543 "eql" 2544 ;;"(I)Z" 2545 ;;-1) 2546 (list "I") 2547 "Z") 2538 2548 (let ((label1 (gensym)) 2539 2549 (label2 (gensym))) … … 2549 2559 (maybe-emit-clear-values arg1) 2550 2560 (emit-push-int arg2) 2551 (emit-invokevirtual +lisp-object-class+ 2552 "eql" 2553 "(I)Z" 2554 -1) 2561 (emit-invokevirtual-2 +lisp-object-class+ 2562 "eql" 2563 ;; "(I)Z" 2564 ;; -1) 2565 (list "I") 2566 "Z") 2555 2567 (let ((label1 (gensym)) 2556 2568 (label2 (gensym))) … … 2569 2581 (single-valued-p arg2)) 2570 2582 (emit-clear-values)) 2571 (emit-invokevirtual +lisp-object-class+ 2572 "EQL" 2573 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 2574 -1) 2583 (emit-invokevirtual-2 +lisp-object-class+ 2584 "EQL" 2585 ;; "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 2586 ;; -1) 2587 (list +lisp-object+) 2588 +lisp-object+) 2575 2589 (emit-move-from-stack target)))) 2576 2590 ) … … 2597 2611 (compile-form (third args) :target :stack) 2598 2612 (maybe-emit-clear-values (third args)) 2599 (emit-invokevirtual +lisp-object-class+ 2600 "setSlotValue" 2601 "(ILorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 2602 -2) 2613 (emit-invokevirtual-2 +lisp-object-class+ 2614 "setSlotValue" 2615 ;;"(ILorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 2616 ;;-2) 2617 (list "I" +lisp-object+) 2618 +lisp-object+) 2603 2619 (emit-move-from-stack target) 2604 2620 t)) … … 2683 2699 2684 2700 (defun emit-call-execute (numargs) 2685 (let ((descriptor 2686 (case numargs 2687 (0 "()Lorg/armedbear/lisp/LispObject;") 2688 (1 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") 2689 (2 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") 2690 (3 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") 2691 (4 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") 2692 (t "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"))) 2693 (stack-effect (if (< numargs 5) 2694 (- numargs) 2695 -1))) 2696 (emit-invokevirtual +lisp-object-class+ "execute" descriptor stack-effect))) 2701 (let ((arg-types (if (<= numargs 4) 2702 (make-list numargs :initial-element +lisp-object+) 2703 (list +lisp-object-array+))) 2704 (return-type +lisp-object+)) 2705 (emit-invokevirtual-2 +lisp-object-class+ "execute" arg-types return-type))) 2697 2706 2698 2707 (defun emit-call-thread-execute (numargs) 2699 (let ((descriptor 2700 (case numargs 2701 (0 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") 2702 (1 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") 2703 (2 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") 2704 (3 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") 2705 (4 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;") 2706 (t "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;"))) 2707 (stack-effect (if (< numargs 5) 2708 (- (1+ numargs)) 2709 -2))) 2710 (emit-invokevirtual +lisp-thread-class+ "execute" descriptor stack-effect))) 2708 (let ((arg-types (if (<= numargs 4) 2709 (make-list (1+ numargs) :initial-element +lisp-object+) 2710 (list +lisp-object+ +lisp-object-array+))) 2711 (return-type +lisp-object+)) 2712 (emit-invokevirtual-2 +lisp-thread-class+ "execute" arg-types return-type))) 2711 2713 2712 2714 (defun compile-function-call (form target representation) … … 2885 2887 2886 2888 (if *closure-variables* 2887 (case (length args) 2888 (0 2889 (emit-invokevirtual +lisp-ctf-class+ 2890 "execute" 2891 "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 2892 -1)) 2893 (1 2894 (emit-invokevirtual +lisp-ctf-class+ 2895 "execute" 2896 "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 2897 -2)) 2898 (2 2899 (emit-invokevirtual +lisp-ctf-class+ 2900 "execute" 2901 "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 2902 -3)) 2903 (3 2904 (emit-invokevirtual +lisp-ctf-class+ 2905 "execute" 2906 "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 2907 -4)) 2908 (4 2909 (emit-invokevirtual +lisp-ctf-class+ 2910 "execute" 2911 "([Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 2912 -5)) 2913 (t 2914 (emit-invokevirtual +lisp-ctf-class+ 2915 "execute" 2916 "([Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 2917 -2))) 2918 ;; No closure variables. 2919 (case (length args) 2920 (0 2921 (emit-invokevirtual +lisp-object-class+ 2922 "execute" 2923 "()Lorg/armedbear/lisp/LispObject;" 2924 0)) 2925 (1 2926 (emit-invokevirtual +lisp-object-class+ 2927 "execute" 2928 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 2929 -1)) 2930 (2 2931 (emit-invokevirtual +lisp-object-class+ 2932 "execute" 2933 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 2934 -2)) 2935 (3 2936 (emit-invokevirtual +lisp-object-class+ 2937 "execute" 2938 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 2939 -3)) 2940 (4 2941 (emit-invokevirtual +lisp-object-class+ 2942 "execute" 2943 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 2944 -4)) 2945 (t 2946 (emit-invokevirtual +lisp-object-class+ 2947 "execute" 2948 "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 2949 -1)))) 2889 (let* ((arg-count (length args)) 2890 (arg-types (if (<= arg-count 4) 2891 (list* +lisp-object-array+ 2892 (make-list arg-count :initial-element +lisp-object+)) 2893 (list +lisp-object-array+ +lisp-object-array+))) 2894 (result-type +lisp-object+)) 2895 (emit-invokevirtual-2 +lisp-ctf-class+ "execute" arg-types result-type)) 2896 ;; No closure variables. 2897 (let* ((arg-count (length args)) 2898 (arg-types (if (<= arg-count 4) 2899 (make-list arg-count :initial-element +lisp-object+) 2900 (list +lisp-object-array+))) 2901 (result-type +lisp-object+)) 2902 (emit-invokevirtual-2 +lisp-object-class+ "execute" arg-types result-type))) 2903 2950 2904 (cond ((null target) 2951 2905 (emit 'pop) … … 2996 2950 (aver (variable-register variable)) 2997 2951 (emit 'iload (variable-register variable)) 2998 (return-from compile-test-2 (if negatep 'iflt 'ifge)) 2999 ) 3000 )) 2952 (return-from compile-test-2 (if negatep 'iflt 'ifge))))) 3001 2953 (when (eq op 'SYMBOLP) 3002 2954 (process-args args) … … 3018 2970 (when s 3019 2971 (process-args args) 3020 (emit-invokevirtual +lisp-object-class+ 3021 s 3022 "()Z" 3023 0) 2972 (emit-invokevirtual-2 +lisp-object-class+ 2973 s 2974 ;; "()Z" 2975 ;; 0) 2976 nil 2977 "Z") 3024 2978 (return-from compile-test-2 (if negatep 'ifne 'ifeq))))) 3025 2979 ;; Otherwise... … … 3050 3004 (emit-clear-values)) 3051 3005 (emit-push-constant-int second) 3052 (emit-invokevirtual +lisp-object-class+3053 (case op3054 (< "isLessThan")3055 (<= "isLessThanOrEqualTo")3056 (> "isGreaterThan")3057 (>= "isGreaterThanOrEqualTo")3058 (= "isEqualTo")3059 (/= "isNotEqualTo"))3060 "(I)Z"3061 -1)3006 (emit-invokevirtual-2 +lisp-object-class+ 3007 (case op 3008 (< "isLessThan") 3009 (<= "isLessThanOrEqualTo") 3010 (> "isGreaterThan") 3011 (>= "isGreaterThanOrEqualTo") 3012 (= "isEqualTo") 3013 (/= "isNotEqualTo")) 3014 (list "I") 3015 "Z") 3062 3016 ;; Java boolean on stack here 3063 3017 (let ((LABEL1 (gensym)) … … 3136 3090 (maybe-emit-clear-values arg1) 3137 3091 (emit-push-int arg2) 3138 (emit-invokevirtual +lisp-object-class+ 3139 (case op 3140 (< "isLessThan") 3141 (<= "isLessThanOrEqualTo") 3142 (> "isGreaterThan") 3143 (>= "isGreaterThanOrEqualTo") 3144 (= "isEqualTo") 3145 (/= "isNotEqualTo")) 3146 "(I)Z" 3147 -1) 3092 (emit-invokevirtual-2 +lisp-object-class+ 3093 (case op 3094 (< "isLessThan") 3095 (<= "isLessThanOrEqualTo") 3096 (> "isGreaterThan") 3097 (>= "isGreaterThanOrEqualTo") 3098 (= "isEqualTo") 3099 (/= "isNotEqualTo")) 3100 ;; "(I)Z" 3101 ;; -1) 3102 (list "I") 3103 "Z") 3148 3104 (return-from compile-test-3 (if negatep 'ifne 'ifeq)))) 3149 3105 … … 3155 3111 (compile-form arg2 :target :stack) 3156 3112 (emit 'swap) 3157 (emit-invokevirtual +lisp-object-class+ 3158 "isGreaterThan" 3159 "(I)Z" 3160 -1) 3113 (emit-invokevirtual-2 +lisp-object-class+ 3114 "isGreaterThan" 3115 ;; "(I)Z" 3116 ;; -1) 3117 (list "I") 3118 "Z") 3161 3119 (return-from compile-test-3 (if negatep 'ifne 'ifeq))))) 3162 3120 … … 3180 3138 (maybe-emit-clear-values first) 3181 3139 (emit-push-constant-int second) 3182 (emit-invokevirtual +lisp-object-class+ s "(I)Z" -1))3140 (emit-invokevirtual-2 +lisp-object-class+ s (list "I") "Z")) 3183 3141 ((setf variable (unboxed-fixnum-variable second)) 3184 3142 (compile-form first :target :stack) … … 3186 3144 (aver (variable-register variable)) 3187 3145 (emit 'iload (variable-register variable)) 3188 (emit-invokevirtual +lisp-object-class+ s "(I)Z" -1))3146 (emit-invokevirtual-2 +lisp-object-class+ s (list "I") "Z")) 3189 3147 (t 3190 3148 (process-args args) 3191 (emit-invokevirtual +lisp-object-class+3192 s3193 "(Lorg/armedbear/lisp/LispObject;)Z"3194 -1)))3149 (emit-invokevirtual-2 +lisp-object-class+ 3150 s 3151 (list +lisp-object+) 3152 "Z"))) 3195 3153 (return-from compile-test-3 (if negatep 'ifne 'ifeq)))))) 3196 3154 … … 3217 3175 3218 3176 (defun compile-if (form &key (target *val*) representation) 3219 ;; (dformat t "compile-if form = ~S~%" form)3220 3177 (let* ((test (second form)) 3221 3178 (consequent (third form)) … … 3283 3240 "(Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 3284 3241 0) 3285 (emit-invokevirtual +lisp-object-class+3286 "execute"3287 "()Lorg/armedbear/lisp/LispObject;"3288 0)3242 (emit-invokevirtual-2 +lisp-object-class+ 3243 "execute" 3244 nil 3245 +lisp-object+) 3289 3246 (emit-move-from-stack target)) 3290 3247 (3 … … 3318 3275 (emit 'swap) 3319 3276 (emit 'aload values-register) 3320 (emit-invokevirtual +lisp-thread-class+ 3321 "accumulateValues" 3322 "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)[Lorg/armedbear/lisp/LispObject;" 3323 -2) 3277 (emit-invokevirtual-2 +lisp-thread-class+ 3278 "accumulateValues" 3279 ;; "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)[Lorg/armedbear/lisp/LispObject;" 3280 ;; -2) 3281 (list +lisp-object+ +lisp-object-array+) 3282 +lisp-object-array+) 3324 3283 (emit 'astore values-register) 3325 3284 (maybe-emit-clear-values values-form)) 3326 3285 (emit 'aload function-register) 3327 3286 (emit 'aload values-register) 3328 (emit-invokevirtual +lisp-object-class+ 3329 "execute" 3330 "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 3331 -1) 3287 (emit-invokevirtual-2 +lisp-object-class+ 3288 "execute" 3289 ;; "([Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 3290 ;; -1) 3291 (list +lisp-object-array+) 3292 +lisp-object+) 3332 3293 (emit-move-from-stack target))))) 3333 3294 … … 3344 3305 +lisp-symbol+) 3345 3306 (emit 'swap) 3346 (emit-invokevirtual +lisp-thread-class+ 3347 "bindSpecial" 3348 "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V" 3349 -3)) 3307 (emit-invokevirtual-2 +lisp-thread-class+ 3308 "bindSpecial" 3309 ;; "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V" 3310 ;; -3)) 3311 (list +lisp-symbol+ +lisp-object+) 3312 nil)) 3350 3313 ((variable-closure-index variable) 3351 3314 (emit 'aload (compiland-closure-register *current-compiland*)) … … 3423 3386 (emit 'aload result-register) 3424 3387 (emit 'bipush (length vars)) 3425 (emit-invokevirtual +lisp-thread-class+ 3426 "getValues" 3427 "(Lorg/armedbear/lisp/LispObject;I)[Lorg/armedbear/lisp/LispObject;" 3428 -2) 3388 (emit-invokevirtual-2 +lisp-thread-class+ 3389 "getValues" 3390 ;; "(Lorg/armedbear/lisp/LispObject;I)[Lorg/armedbear/lisp/LispObject;" 3391 ;; -2) 3392 (list +lisp-object+ "I") 3393 +lisp-object-array+) 3429 3394 ;; Values array is now on the stack at runtime. 3430 3395 (label LABEL2) … … 3560 3525 (declare-symbol (variable-name variable)) 3561 3526 +lisp-symbol+) 3562 (emit-invokevirtual +lisp-thread-class+ 3563 "bindSpecialToCurrentValue" 3564 "(Lorg/armedbear/lisp/Symbol;)V" 3565 -2) 3527 (emit-invokevirtual-2 +lisp-thread-class+ 3528 "bindSpecialToCurrentValue" 3529 ;; "(Lorg/armedbear/lisp/Symbol;)V" 3530 ;; -2) 3531 (list +lisp-symbol+) 3532 nil) 3566 3533 (setf boundp t)) 3567 3534 (initform … … 4013 3980 (emit 'dup)) 4014 3981 (compile-form (second args) :target :stack) 4015 (emit-invokevirtual +lisp-object-class+ 4016 "setCdr" 4017 "(Lorg/armedbear/lisp/LispObject;)V" 4018 -2) 3982 (emit-invokevirtual-2 +lisp-object-class+ 3983 "setCdr" 3984 ;; "(Lorg/armedbear/lisp/LispObject;)V" 3985 ;; -2) 3986 (list +lisp-object+) 3987 nil) 4019 3988 (when target 4020 3989 (emit-move-from-stack target)))) … … 4182 4151 (emit-invokestatic +lisp-class+ 4183 4152 "makeCompiledClosure" 4184 "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 4153 ;; "(Lorg/armedbear/lisp/LispObject;[Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 4154 (make-descriptor (list +lisp-object+ +lisp-object-array+) 4155 +lisp-object+) 4185 4156 -1) 4186 4157 (emit 'checkcast "org/armedbear/lisp/CompiledClosure") … … 4236 4207 (declare-symbol name) 4237 4208 +lisp-symbol+) 4238 (emit-invokevirtual +lisp-object-class+ 4239 "getSymbolFunctionOrDie" 4240 "()Lorg/armedbear/lisp/LispObject;" 4241 0) 4209 (emit-invokevirtual-2 +lisp-object-class+ 4210 "getSymbolFunctionOrDie" 4211 ;; "()Lorg/armedbear/lisp/LispObject;" 4212 ;; 0) 4213 nil 4214 +lisp-object+) 4242 4215 (emit-move-from-stack target)))) 4243 4216 ((and (consp name) (eq (car name) 'SETF)) … … 4261 4234 (declare-symbol (cadr name)) 4262 4235 +lisp-symbol+) 4263 (emit-invokevirtual +lisp-symbol-class+ 4264 "getSymbolSetfFunctionOrDie" 4265 "()Lorg/armedbear/lisp/LispObject;" 4266 0) 4236 (emit-invokevirtual-2 +lisp-symbol-class+ 4237 "getSymbolSetfFunctionOrDie" 4238 ;; "()Lorg/armedbear/lisp/LispObject;" 4239 ;; 0) 4240 nil 4241 +lisp-object+) 4267 4242 (emit-move-from-stack target)))) 4268 4243 ((compiland-p name) … … 4318 4293 (maybe-emit-clear-values arg1) 4319 4294 (emit 'iload (variable-register var2)) 4320 (emit-invokevirtual +lisp-object-class+ 4321 "ash" 4322 "(I)Lorg/armedbear/lisp/LispObject;" 4323 -1) 4295 (emit-invokevirtual-2 +lisp-object-class+ 4296 "ash" 4297 ;; "(I)Lorg/armedbear/lisp/LispObject;" 4298 ;; -1) 4299 (list "I") 4300 +lisp-object+) 4324 4301 (when (eq representation :unboxed-fixnum) 4325 4302 (emit-unbox-fixnum)) … … 4330 4307 (maybe-emit-clear-values arg1) 4331 4308 (emit-push-constant-int arg2) 4332 (emit-invokevirtual +lisp-object-class+ 4333 "ash" 4334 "(I)Lorg/armedbear/lisp/LispObject;" 4335 -1) 4309 (emit-invokevirtual-2 +lisp-object-class+ 4310 "ash" 4311 ;; "(I)Lorg/armedbear/lisp/LispObject;" 4312 ;; -1) 4313 (list "I") 4314 +lisp-object+) 4336 4315 (when (eq representation :unboxed-fixnum) 4337 4316 (emit-unbox-fixnum)) … … 4393 4372 (maybe-emit-clear-values arg1) 4394 4373 (emit-push-constant-int arg2) 4395 (emit-invokevirtual +lisp-object-class+ 4396 "logand" 4397 "(I)Lorg/armedbear/lisp/LispObject;" 4398 -1) 4374 (emit-invokevirtual-2 +lisp-object-class+ 4375 "logand" 4376 ;; "(I)Lorg/armedbear/lisp/LispObject;" 4377 ;; -1) 4378 (list "I") 4379 +lisp-object+) 4399 4380 (when (eq representation :unboxed-fixnum) 4400 4381 (emit-unbox-fixnum)) … … 4436 4417 (cond 4437 4418 ((eq representation :unboxed-fixnum) 4438 (emit-invokevirtual +lisp-object-class+ 4439 "length" 4440 "()I" 4441 0)) 4419 (emit-invokevirtual-2 +lisp-object-class+ 4420 "length" 4421 ;; "()I" 4422 ;; 0)) 4423 nil 4424 "I")) 4442 4425 (t 4443 (emit-invokevirtual +lisp-object-class+ 4444 "LENGTH" 4445 "()Lorg/armedbear/lisp/LispObject;" 4446 0))) 4426 (emit-invokevirtual-2 +lisp-object-class+ 4427 "LENGTH" 4428 ;; "()Lorg/armedbear/lisp/LispObject;" 4429 ;; 0))) 4430 nil 4431 +lisp-object+))) 4447 4432 (emit-move-from-stack target representation))) 4448 4433 … … 4459 4444 (emit-clear-values)) 4460 4445 (emit 'swap) 4461 (emit-invokevirtual +lisp-object-class+ 4462 "NTH" 4463 "(I)Lorg/armedbear/lisp/LispObject;" 4464 -1) 4446 (emit-invokevirtual-2 +lisp-object-class+ 4447 "NTH" 4448 ;; "(I)Lorg/armedbear/lisp/LispObject;" 4449 ;; -1) 4450 (list "I") 4451 +lisp-object+) 4465 4452 (when (eq representation :unboxed-fixnum) 4466 4453 (emit-unbox-fixnum)) … … 4547 4534 (maybe-emit-clear-values arg2) 4548 4535 (emit 'swap) 4549 (emit-invokevirtual +lisp-object-class+ 4550 "add" 4551 "(I)Lorg/armedbear/lisp/LispObject;" 4552 -1) 4536 (emit-invokevirtual-2 +lisp-object-class+ 4537 "add" 4538 ;; "(I)Lorg/armedbear/lisp/LispObject;" 4539 ;; -1) 4540 (list "I") 4541 +lisp-object+) 4553 4542 (when (eq representation :unboxed-fixnum) 4554 4543 (emit-unbox-fixnum)) … … 4559 4548 (maybe-emit-clear-values arg1) 4560 4549 (emit-push-int arg2) 4561 (emit-invokevirtual +lisp-object-class+ 4562 "add" 4563 "(I)Lorg/armedbear/lisp/LispObject;" 4564 -1) 4550 (emit-invokevirtual-2 +lisp-object-class+ 4551 "add" 4552 ;; "(I)Lorg/armedbear/lisp/LispObject;" 4553 ;; -1) 4554 (list "I") 4555 +lisp-object+) 4565 4556 (when (eq representation :unboxed-fixnum) 4566 4557 (emit-unbox-fixnum)) … … 4653 4644 (maybe-emit-clear-values arg1) 4654 4645 (emit-push-int arg2) 4655 (emit-invokevirtual +lisp-object-class+ 4656 "subtract" 4657 "(I)Lorg/armedbear/lisp/LispObject;" 4658 -1) 4646 (emit-invokevirtual-2 +lisp-object-class+ 4647 "subtract" 4648 ;; "(I)Lorg/armedbear/lisp/LispObject;" 4649 ;; -1) 4650 (list "I") 4651 +lisp-object+) 4659 4652 (when (eq representation :unboxed-fixnum) 4660 4653 (emit-unbox-fixnum)) … … 4684 4677 (single-valued-p (third form))) 4685 4678 (emit-clear-values)) 4686 (emit-invokevirtual +lisp-object-class+ 4687 "SCHAR" 4688 "(I)Lorg/armedbear/lisp/LispObject;" 4689 -1) 4679 (emit-invokevirtual-2 +lisp-object-class+ 4680 "SCHAR" 4681 ;; "(I)Lorg/armedbear/lisp/LispObject;" 4682 ;; -1) 4683 (list "I") 4684 +lisp-object+) 4690 4685 (emit-move-from-stack target)) 4691 4686 … … 4699 4694 (single-valued-p (third form))) 4700 4695 (emit-clear-values)) 4701 (emit-invokevirtual +lisp-object-class+ 4702 "AREF" 4703 "(I)Lorg/armedbear/lisp/LispObject;" 4704 -1) 4696 (emit-invokevirtual-2 +lisp-object-class+ 4697 "AREF" 4698 ;; "(I)Lorg/armedbear/lisp/LispObject;" 4699 ;; -1) 4700 (list "I") 4701 +lisp-object+) 4705 4702 (emit-move-from-stack target)) 4706 4703 … … 4767 4764 (compile-form arg1 :target :stack) 4768 4765 (compile-form arg2 :target :stack)))) 4769 (emit-invokevirtual +lisp-thread-class+ 4770 "setValues" 4771 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 4772 -2) 4766 (emit-invokevirtual-2 +lisp-thread-class+ 4767 "setValues" 4768 ;; "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 4769 ;; -2) 4770 (list +lisp-object+ +lisp-object+) 4771 +lisp-object+) 4773 4772 (emit-move-from-stack target)) 4774 4773 (3 … … 4776 4775 (dolist (arg args) 4777 4776 (compile-form arg :target :stack)) 4778 (emit-invokevirtual +lisp-thread-class+ 4779 "setValues" 4780 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 4781 -3) 4777 (emit-invokevirtual-2 +lisp-thread-class+ 4778 "setValues" 4779 ;; "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 4780 ;; -3) 4781 (list +lisp-object+ +lisp-object+ +lisp-object+) 4782 +lisp-object+) 4782 4783 (emit-move-from-stack target)) 4783 4784 (t … … 4790 4791 +lisp-symbol+) 4791 4792 (emit-push-current-thread) 4792 (emit-invokevirtual +lisp-symbol-class+ 4793 "symbolValue" 4794 "(Lorg/armedbear/lisp/LispThread;)Lorg/armedbear/lisp/LispObject;" 4795 -1) 4793 (emit-invokevirtual-2 +lisp-symbol-class+ 4794 "symbolValue" 4795 ;; "(Lorg/armedbear/lisp/LispThread;)Lorg/armedbear/lisp/LispObject;" 4796 ;; -1) 4797 (list +lisp-thread+) 4798 +lisp-object+) 4796 4799 (when (eq representation :unboxed-fixnum) 4797 4800 (emit-unbox-fixnum)) … … 4873 4876 (compile-form value-form :target :stack) 4874 4877 (maybe-emit-clear-values value-form) 4875 (emit-invokevirtual +lisp-thread-class+ 4876 "setSpecialVariable" 4877 "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 4878 -2) 4878 (emit-invokevirtual-2 +lisp-thread-class+ 4879 "setSpecialVariable" 4880 ;; "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)Lorg/armedbear/lisp/LispObject;" 4881 ;; -2) 4882 (list +lisp-symbol+ +lisp-object+) 4883 +lisp-object+) 4879 4884 (emit-move-from-stack target)) 4880 4885 ((and (eq (variable-representation variable) :unboxed-fixnum) … … 4934 4939 (emit-push-current-thread) 4935 4940 (emit 'aload tag-register) 4936 (emit-invokevirtual +lisp-thread-class+ 4937 "pushCatchTag" 4938 "(Lorg/armedbear/lisp/LispObject;)V" 4939 -2) ; Stack depth is 0. 4941 (emit-invokevirtual-2 +lisp-thread-class+ 4942 "pushCatchTag" 4943 ;; "(Lorg/armedbear/lisp/LispObject;)V" 4944 ;; -2) 4945 (list +lisp-object+) 4946 nil) 4947 ; Stack depth is 0. 4940 4948 (emit 'label label1) ; Start of protected range. 4941 4949 ;; Implicit PROGN. … … 4952 4960 (emit 'if_acmpne label4) ; Stack depth is 1. 4953 4961 (emit 'aload *thread*) 4954 (emit-invokevirtual +lisp-throw-class+ 4955 "getResult" 4956 "(Lorg/armedbear/lisp/LispThread;)Lorg/armedbear/lisp/LispObject;" 4957 -1) 4962 (emit-invokevirtual-2 +lisp-throw-class+ 4963 "getResult" 4964 ;; "(Lorg/armedbear/lisp/LispThread;)Lorg/armedbear/lisp/LispObject;" 4965 ;; -1) 4966 (list +lisp-thread+) 4967 +lisp-object+) 4958 4968 (emit-move-from-stack target) ; Stack depth is 0. 4959 4969 (emit 'goto label5) … … 4961 4971 ;; A Throwable object is on the runtime stack here. Stack depth is 1. 4962 4972 (emit 'aload *thread*) 4963 (emit-invokevirtual +lisp-thread-class+ 4964 "popCatchTag" 4965 "()V" 4966 -1) 4973 (emit-invokevirtual-2 +lisp-thread-class+ 4974 "popCatchTag" 4975 ;; "()V" 4976 ;; -1) 4977 nil 4978 nil) 4967 4979 (emit 'athrow) ; And we're gone. 4968 4980 (emit 'label label5) 4969 4981 ;; Finally... 4970 4982 (emit 'aload *thread*) 4971 (emit-invokevirtual +lisp-thread-class+ 4972 "popCatchTag" 4973 "()V" 4974 -1) 4983 (emit-invokevirtual-2 +lisp-thread-class+ 4984 "popCatchTag" 4985 ;; "()V" 4986 ;; -1) 4987 nil 4988 nil) 4975 4989 (let ((handler1 (make-handler :from label1 4976 4990 :to label2 … … 5020 5034 (emit-clear-values) ; Do this unconditionally! (MISC.503) 5021 5035 (compile-form (third form) :target :stack) ; Result. 5022 (emit-invokevirtual +lisp-thread-class+ 5023 "throwToTag" 5024 "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V" 5025 -3) 5036 (emit-invokevirtual-2 +lisp-thread-class+ 5037 "throwToTag" 5038 ;; "(Lorg/armedbear/lisp/LispObject;Lorg/armedbear/lisp/LispObject;)V" 5039 ;; -3) 5040 (list +lisp-object+ +lisp-object+) 5041 nil) 5026 5042 ;; Following code will not be reached. 5027 5043 (when target … … 5512 5528 +lisp-symbol+) 5513 5529 (emit 'aload (variable-register variable)) 5514 (emit-invokevirtual +lisp-thread-class+ 5515 "bindSpecial" 5516 "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V" 5517 -3) 5530 (emit-invokevirtual-2 +lisp-thread-class+ 5531 "bindSpecial" 5532 ;; "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V" 5533 ;; -3) 5534 (list +lisp-symbol+ +lisp-object+) 5535 nil) 5518 5536 (setf (variable-register variable) nil)) 5519 5537 ((variable-index variable) … … 5526 5544 (emit 'bipush (variable-index variable)) 5527 5545 (emit 'aaload) 5528 (emit-invokevirtual +lisp-thread-class+ 5529 "bindSpecial" 5530 "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V" 5531 -3) 5546 (emit-invokevirtual-2 +lisp-thread-class+ 5547 "bindSpecial" 5548 ;; "(Lorg/armedbear/lisp/Symbol;Lorg/armedbear/lisp/LispObject;)V" 5549 ;; -3) 5550 (list +lisp-symbol+ +lisp-object+) 5551 nil) 5532 5552 (setf (variable-index variable) nil))))) 5533 5553 … … 5546 5566 (maybe-generate-arg-count-check) 5547 5567 (maybe-generate-interrupt-check) 5548 (cond 5549 (*child-p* 5550 (dformat t "prologue experimental case (child)~%") 5551 (when *hairy-arglist-p* 5552 (dformat t "prologue case 1~%") 5553 (emit 'aload_0) ; this 5554 (aver (not (null (compiland-argument-register compiland)))) 5555 (emit 'aload (compiland-argument-register compiland)) ; arg vector 5556 (cond ((or (memq '&optional args) (memq '&key args)) 5557 (emit 'iconst_0) 5558 (emit-invokevirtual *this-class* 5559 "processArgs" 5560 "([Lorg/armedbear/lisp/LispObject;I)[Lorg/armedbear/lisp/LispObject;" 5561 -2)) 5562 (t 5563 (emit-invokevirtual *this-class* 5564 "fastProcessArgs" 5565 "([Lorg/armedbear/lisp/LispObject;)[Lorg/armedbear/lisp/LispObject;" 5566 -1))) 5567 (emit 'astore (compiland-argument-register compiland)))) 5568 (*hairy-arglist-p* 5569 (dformat t "prologue case 1~%") 5568 5569 (when *hairy-arglist-p* 5570 5570 (emit 'aload_0) ; this 5571 5571 (aver (not (null (compiland-argument-register compiland)))) 5572 5572 (emit 'aload (compiland-argument-register compiland)) ; arg vector 5573 (cond ((or (memq '& optional args) (memq '&keyargs))5573 (cond ((or (memq '&OPTIONAL args) (memq '&KEY args)) 5574 5574 (emit 'iconst_0) 5575 (emit-invokevirtual *this-class*5576 "processArgs"5577 "([Lorg/armedbear/lisp/LispObject;I)[Lorg/armedbear/lisp/LispObject;"5578 -2))5575 (emit-invokevirtual-2 *this-class* 5576 "processArgs" 5577 (list +lisp-object-array+ "I") 5578 +lisp-object-array+)) 5579 5579 (t 5580 (emit-invokevirtual *this-class*5581 "fastProcessArgs"5582 "([Lorg/armedbear/lisp/LispObject;)[Lorg/armedbear/lisp/LispObject;"5583 -1)))5580 (emit-invokevirtual-2 *this-class* 5581 "fastProcessArgs" 5582 (list +lisp-object-array+) 5583 +lisp-object-array+))) 5584 5584 (emit 'astore (compiland-argument-register compiland))) 5585 ((not *using-arg-array*) 5585 5586 (cond 5587 ((and (not *child-p*) (not *using-arg-array*)) 5586 5588 (dformat t "prologue case 2~%") 5587 5589 (dolist (variable (reverse *visible-variables*))
Note: See TracChangeset
for help on using the changeset viewer.
