Changeset 8401
- Timestamp:
- 01/25/05 05:37:05 (18 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/j/src/org/armedbear/lisp/jvm.lisp
r8400 r8401 2 2 ;;; 3 3 ;;; Copyright (C) 2003-2005 Peter Graves 4 ;;; $Id: jvm.lisp,v 1.37 0 2005-01-25 02:06:59piso Exp $4 ;;; $Id: jvm.lisp,v 1.371 2005-01-25 05:37:05 piso Exp $ 5 5 ;;; 6 6 ;;; This program is free software; you can redistribute it and/or … … 167 167 ;; returns variable or nil 168 168 (defun unboxed-fixnum-variable (obj) 169 (cond 170 ((symbolp obj) 171 (let ((variable (find-visible-variable obj))) 172 (if (and variable 173 (eq (variable-representation variable) :unboxed-fixnum)) 174 variable 175 nil))) 176 ((variable-p obj) 177 (if (eq (variable-representation obj) :unboxed-fixnum) 178 obj 179 nil)) 180 (t 181 nil))) 169 (cond ((symbolp obj) 170 (let ((variable (find-visible-variable obj))) 171 (if (and variable 172 (eq (variable-representation variable) :unboxed-fixnum)) 173 variable 174 nil))) 175 ((variable-p obj) 176 (if (eq (variable-representation obj) :unboxed-fixnum) 177 obj 178 nil)) 179 (t 180 nil))) 182 181 183 182 (defun arg-is-fixnum-p (arg) … … 348 347 (t 349 348 (dformat t "adding free special ~S~%" sym) 350 (push (make-variable :name sym :special-p t) free-specials)))) 351 )) 349 (push (make-variable :name sym :special-p t) free-specials)))))) 352 350 (TYPE 353 351 (dolist (sym (cddr decl)) … … 592 590 (progn 593 591 (incf (variable-writes variable)) 594 (cond 595 ((eq (variable-compiland variable) *current-compiland*) 596 (dformat t "p1-setq: write ~S~%" arg1)) 597 (t 598 (dformat t "p1-setq: non-local write ~S~%" arg1) 599 (setf (variable-used-non-locally-p variable) t)))) 592 (cond ((eq (variable-compiland variable) *current-compiland*) 593 (dformat t "p1-setq: write ~S~%" arg1)) 594 (t 595 (dformat t "p1-setq: non-local write ~S~%" arg1) 596 (setf (variable-used-non-locally-p variable) t)))) 600 597 (dformat t "p1-setq: unknown variable ~S~%" arg1))) 601 598 (list 'SETQ arg1 (p1 arg2)))) … … 605 602 (let ((type (second form)) 606 603 (expr (third form))) 607 (cond 608 ((and (listp type) (eq (car type) 'VALUES)) 609 ;; FIXME 610 (p1 expr)) 611 ((= *safety* 3) 612 (dformat t "p1-the expr = ~S~%" expr) 613 (let* ((sym (gensym)) 614 (new-expr 615 `(let ((,sym ,expr)) 616 (sys::require-type ,sym ',type) 617 ,sym))) 618 (dformat t "p1-the new-expr = ~S~%" new-expr) 619 (p1 new-expr))) 620 (t 621 (dformat t "p1-the t case expr = ~S~%" expr) 622 (if (subtypep type 'FIXNUM) 623 (list 'THE type (p1 expr)) 624 (p1 expr)))))) 604 (cond ((and (listp type) (eq (car type) 'VALUES)) 605 ;; FIXME 606 (p1 expr)) 607 ((= *safety* 3) 608 (dformat t "p1-the expr = ~S~%" expr) 609 (let* ((sym (gensym)) 610 (new-expr 611 `(let ((,sym ,expr)) 612 (sys::require-type ,sym ',type) 613 ,sym))) 614 (dformat t "p1-the new-expr = ~S~%" new-expr) 615 (p1 new-expr))) 616 (t 617 (dformat t "p1-the t case expr = ~S~%" expr) 618 (if (subtypep type 'FIXNUM) 619 (list 'THE type (p1 expr)) 620 (p1 expr)))))) 625 621 626 622 (defun p1-default (form) … … 647 643 648 644 (defun p1 (form) 649 (cond 650 ((symbolp form) 651 (cond 652 ((constantp form) ; a DEFCONSTANT 653 (let ((value (symbol-value form))) 654 (if (numberp value) 655 value 656 form))) 657 ((keywordp form) 658 form) 659 (t 660 (let ((variable (find-visible-variable form))) 661 (if variable 662 (progn 663 (incf (variable-reads variable)) 664 (cond 665 ((eq (variable-compiland variable) *current-compiland*) 666 (dformat t "p1: read ~S~%" form)) 645 (cond ((symbolp form) 646 (cond ((constantp form) ; a DEFCONSTANT 647 (let ((value (symbol-value form))) 648 (if (numberp value) 649 value 650 form))) 651 ((keywordp form) 652 form) 667 653 (t 668 (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%" 669 form 670 (compiland-name (variable-compiland variable)) 671 (compiland-name *current-compiland*)) 672 (setf (variable-used-non-locally-p variable) t)))) 673 (dformat t "p1: unknown variable ~S~%" form))) 674 form))) 675 ((atom form) 676 form) 677 (t 678 (let ((op (car form)) 679 handler) 680 (cond ((symbolp op) 681 (cond ((setf handler (get op 'p1-handler)) 682 (funcall handler form)) 683 ((macro-function op) 684 (p1 (macroexpand form))) 685 ((special-operator-p op) 686 (error "P1: unsupported special operator ~S" op)) 687 (t 688 ;; Function call. 689 (let ((new-form (rewrite-function-call form))) 690 (when (neq new-form form) 691 (dformat t "old form = ~S~%" form) 692 (dformat t "new form = ~S~%" new-form) 693 (return-from p1 (p1 new-form)))) 694 (let ((source-transform (source-transform op))) 695 (when source-transform 696 (let ((new-form (expand-source-transform form))) 697 (when (neq new-form form) 698 (return-from p1 (p1 new-form)))))) 699 (let ((expansion (inline-expansion op))) 700 (when expansion 701 (return-from p1 (p1 (expand-inline form expansion))))) 702 (let ((local-function (find-local-function op))) 703 (when local-function 704 (dformat t "p1 local function ~S~%" op) 705 (unless (eq (local-function-compiland local-function) 706 *current-compiland*) 707 (let ((variable (local-function-variable local-function))) 708 (when variable 709 (unless (eq (variable-compiland variable) *current-compiland*) 710 (dformat t "p1 ~S used non-locally~%" (variable-name variable)) 711 (setf (variable-used-non-locally-p variable) t))))))) 712 (list* op (mapcar #'p1 (cdr form))) 713 ))) 714 ((and (consp op) (eq (car op) 'LAMBDA)) 715 (p1 (list* 'FUNCALL form))) 716 (t 717 form)))))) 654 (let ((variable (find-visible-variable form))) 655 (if variable 656 (progn 657 (incf (variable-reads variable)) 658 (cond 659 ((eq (variable-compiland variable) *current-compiland*) 660 (dformat t "p1: read ~S~%" form)) 661 (t 662 (dformat t "p1: non-local read ~S variable-compiland = ~S current compiland = ~S~%" 663 form 664 (compiland-name (variable-compiland variable)) 665 (compiland-name *current-compiland*)) 666 (setf (variable-used-non-locally-p variable) t)))) 667 (dformat t "p1: unknown variable ~S~%" form))) 668 form))) 669 ((atom form) 670 form) 671 (t 672 (let ((op (car form)) 673 handler) 674 (cond ((symbolp op) 675 (cond ((setf handler (get op 'p1-handler)) 676 (funcall handler form)) 677 ((macro-function op) 678 (p1 (macroexpand form))) 679 ((special-operator-p op) 680 (error "P1: unsupported special operator ~S" op)) 681 (t 682 ;; Function call. 683 (let ((new-form (rewrite-function-call form))) 684 (when (neq new-form form) 685 (dformat t "old form = ~S~%" form) 686 (dformat t "new form = ~S~%" new-form) 687 (return-from p1 (p1 new-form)))) 688 (let ((source-transform (source-transform op))) 689 (when source-transform 690 (let ((new-form (expand-source-transform form))) 691 (when (neq new-form form) 692 (return-from p1 (p1 new-form)))))) 693 (let ((expansion (inline-expansion op))) 694 (when expansion 695 (return-from p1 (p1 (expand-inline form expansion))))) 696 (let ((local-function (find-local-function op))) 697 (when local-function 698 (dformat t "p1 local function ~S~%" op) 699 (unless (eq (local-function-compiland local-function) 700 *current-compiland*) 701 (let ((variable (local-function-variable local-function))) 702 (when variable 703 (unless (eq (variable-compiland variable) *current-compiland*) 704 (dformat t "p1 ~S used non-locally~%" (variable-name variable)) 705 (setf (variable-used-non-locally-p variable) t))))))) 706 (list* op (mapcar #'p1 (cdr form))) 707 ))) 708 ((and (consp op) (eq (car op) 'LAMBDA)) 709 (p1 (list* 'FUNCALL form))) 710 (t 711 form)))))) 718 712 719 713 (defun install-p1-handler (symbol handler) … … 1487 1481 (aver (variable-p variable)) 1488 1482 (dformat t "var-ref variable = ~S " (variable-name variable)) 1489 (cond 1490 ((variable-register variable) 1491 (dformat t "register = ~S~%" (variable-register variable)) 1492 (emit 'aload (variable-register variable)) 1493 (emit-move-from-stack target)) 1494 ((variable-special-p variable) 1495 (dformat t "soecial~%") 1496 (compile-special-reference (variable-name variable) target nil)) 1497 ((variable-closure-index variable) 1498 (dformat t "closure-index = ~S~%" (variable-closure-index variable)) 1499 (aver (not (null (compiland-closure-register *current-compiland*)))) 1500 (emit 'aload (compiland-closure-register *current-compiland*)) 1501 (emit-push-constant-int (variable-closure-index variable)) 1502 (emit 'aaload) 1503 (emit-move-from-stack target)) 1504 ((variable-index variable) 1505 (dformat t "index = ~S~%" (variable-index variable)) 1506 (aver (not (null (compiland-argument-register *current-compiland*)))) 1507 (emit 'aload (compiland-argument-register *current-compiland*)) 1508 (emit-push-constant-int (variable-index variable)) 1509 (emit 'aaload) 1510 (emit-move-from-stack target)) 1511 (t 1512 (dformat t "VAR-REF unhandled case variable = ~S~%" (variable-name variable)) 1513 (aver (progn 'unhandled-case nil)))) 1483 (cond ((variable-register variable) 1484 (dformat t "register = ~S~%" (variable-register variable)) 1485 (emit 'aload (variable-register variable)) 1486 (emit-move-from-stack target)) 1487 ((variable-special-p variable) 1488 (dformat t "soecial~%") 1489 (compile-special-reference (variable-name variable) target nil)) 1490 ((variable-closure-index variable) 1491 (dformat t "closure-index = ~S~%" (variable-closure-index variable)) 1492 (aver (not (null (compiland-closure-register *current-compiland*)))) 1493 (emit 'aload (compiland-closure-register *current-compiland*)) 1494 (emit-push-constant-int (variable-closure-index variable)) 1495 (emit 'aaload) 1496 (emit-move-from-stack target)) 1497 ((variable-index variable) 1498 (dformat t "index = ~S~%" (variable-index variable)) 1499 (aver (not (null (compiland-argument-register *current-compiland*)))) 1500 (emit 'aload (compiland-argument-register *current-compiland*)) 1501 (emit-push-constant-int (variable-index variable)) 1502 (emit 'aaload) 1503 (emit-move-from-stack target)) 1504 (t 1505 (dformat t "VAR-REF unhandled case variable = ~S~%" (variable-name variable)) 1506 (aver (progn 'unhandled-case nil)))) 1514 1507 (when (eq representation :unboxed-fixnum) 1515 1508 (dformat t "resolve-variables calling emit-unbox-fixnum~%") … … 1530 1523 (emit 'bipush (variable-closure-index variable)) 1531 1524 (emit 'swap) ; array index value 1532 (emit 'aastore) 1533 ) 1525 (emit 'aastore)) 1534 1526 (t 1535 1527 (dformat t "var-set fall-through case~%") … … 2018 2010 (g (gethash symbol *declared-symbols*))) 2019 2011 (cond (g 2020 (emit 'getstatic 2021 *this-class* 2022 g 2023 +lisp-symbol+)) 2012 (emit 'getstatic *this-class* g +lisp-symbol+)) 2024 2013 (t 2025 2014 (emit 'ldc (pool-string (symbol-name symbol))) … … 2278 2267 (emit-move-from-stack target) 2279 2268 t) 2280 (t nil))))) 2269 (t 2270 nil))))) 2281 2271 2282 2272 (defparameter binary-operators (make-hash-table :test 'eq)) … … 2382 2372 (let ((arg1 (second form)) 2383 2373 (arg2 (third form))) 2384 (cond 2385 ((and (fixnum-or-unboxed-variable-p arg1)2386 ( fixnum-or-unboxed-variable-p arg2))2387 (emit-push-int arg1)2388 (emit-push-int arg2)2389 (let ((label1 (gensym))2390 (label2 (gensym)))2391 (emit 'if_icmpeq `,label1)2392 (emit-push-nil)2393 (emit 'goto `,label2)2394 (emit 'label `,label1)2395 (emit-push-t)2396 (emit 'label `,label2))2397 (emit-move-from-stack target))2398 ((fixnum-or-unboxed-variable-parg1)2399 (emit-push-int arg1)2400 (compile-form arg2 :target :stack)2401 (maybe-emit-clear-values arg2)2402 (emit 'swap)2403 (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z")2404 (let ((label1 (gensym))2405 (label2 (gensym)))2406 (emit 'ifne `,label1)2407 (emit-push-nil)2408 (emit 'goto `,label2)2409 (emit 'label `,label1)2410 (emit-push-t)2411 (emit 'label `,label2))2412 (emit-move-from-stack target))2413 ((fixnum-or-unboxed-variable-p arg2)2414 (compile-form arg1 :target :stack)2415 (maybe-emit-clear-values arg1)2416 (emit-push-int arg2)2417 (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z")2418 (let ((label1 (gensym))2419 (label2 (gensym)))2420 (emit 'ifne `,label1)2421 (emit-push-nil)2422 (emit 'goto `,label2)2423 (emit 'label `,label1)2424 (emit-push-t)2425 (emit 'label `,label2))2426 (emit-move-from-stack target))2427 (t2428 (compile-form arg1:target :stack)2429 (compile-form arg2 :target :stack)2430 (unless (and (single-valued-p arg1)2431 (single-valued-p arg2))2432 (emit-clear-values))2433 (emit-invokevirtual +lisp-object-class+ "EQL"(list +lisp-object+) +lisp-object+)2434 (emit-move-from-stack target)))))2374 (cond ((and (fixnum-or-unboxed-variable-p arg1) 2375 (fixnum-or-unboxed-variable-p arg2)) 2376 (emit-push-int arg1) 2377 (emit-push-int arg2) 2378 (let ((label1 (gensym)) 2379 (label2 (gensym))) 2380 (emit 'if_icmpeq `,label1) 2381 (emit-push-nil) 2382 (emit 'goto `,label2) 2383 (emit 'label `,label1) 2384 (emit-push-t) 2385 (emit 'label `,label2)) 2386 (emit-move-from-stack target)) 2387 ((fixnum-or-unboxed-variable-p arg1) 2388 (emit-push-int arg1) 2389 (compile-form arg2 :target :stack) 2390 (maybe-emit-clear-values arg2) 2391 (emit 'swap) 2392 (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z") 2393 (let ((label1 (gensym)) 2394 (label2 (gensym))) 2395 (emit 'ifne `,label1) 2396 (emit-push-nil) 2397 (emit 'goto `,label2) 2398 (emit 'label `,label1) 2399 (emit-push-t) 2400 (emit 'label `,label2)) 2401 (emit-move-from-stack target)) 2402 ((fixnum-or-unboxed-variable-p arg2) 2403 (compile-form arg1 :target :stack) 2404 (maybe-emit-clear-values arg1) 2405 (emit-push-int arg2) 2406 (emit-invokevirtual +lisp-object-class+ "eql" '("I") "Z") 2407 (let ((label1 (gensym)) 2408 (label2 (gensym))) 2409 (emit 'ifne `,label1) 2410 (emit-push-nil) 2411 (emit 'goto `,label2) 2412 (emit 'label `,label1) 2413 (emit-push-t) 2414 (emit 'label `,label2)) 2415 (emit-move-from-stack target)) 2416 (t 2417 (compile-form arg1 :target :stack) 2418 (compile-form arg2 :target :stack) 2419 (unless (and (single-valued-p arg1) 2420 (single-valued-p arg2)) 2421 (emit-clear-values)) 2422 (emit-invokevirtual +lisp-object-class+ "EQL" 2423 (list +lisp-object+) +lisp-object+) 2424 (emit-move-from-stack target))))) 2435 2425 2436 2426 (defun compile-function-call-3 (op args target) … … 2571 2561 (unless (> *speed* *debug*) 2572 2562 (emit-push-current-thread)) 2573 (cond 2574 ((eq op (compiland-name *current-compiland*)) ; recursive call 2575 (emit 'aload 0)) ; this 2576 ((inline-ok op) 2577 (emit 'getstatic 2578 *this-class* 2579 (declare-function op) 2580 +lisp-object+)) 2581 ((null (symbol-package op)) 2582 (let ((g (if *compile-file-truename* 2583 (declare-object-as-string op) 2584 (declare-object op)))) 2585 (emit 'getstatic 2586 *this-class* 2587 g 2588 +lisp-object+))) 2589 (t 2590 (emit 'getstatic 2591 *this-class* 2592 (declare-symbol op) 2593 +lisp-symbol+))) 2563 (cond ((eq op (compiland-name *current-compiland*)) ; recursive call 2564 (emit 'aload 0)) ; this 2565 ((inline-ok op) 2566 (emit 'getstatic *this-class* (declare-function op) +lisp-object+)) 2567 ((null (symbol-package op)) 2568 (let ((g (if *compile-file-truename* 2569 (declare-object-as-string op) 2570 (declare-object op)))) 2571 (emit 'getstatic *this-class* g +lisp-object+))) 2572 (t 2573 (emit 'getstatic *this-class* (declare-symbol op) +lisp-symbol+))) 2594 2574 (process-args args) 2595 2575 (if (> *speed* *debug*) … … 2690 2670 (declare-local-function local-function) 2691 2671 (declare-object (local-function-function local-function))))) 2692 (emit 'getstatic 2693 *this-class* 2694 g 2695 +lisp-object+)))) ; Stack: template-function 2672 (emit 'getstatic *this-class* g +lisp-object+)))) ; Stack: template-function 2696 2673 2697 2674 (when *closure-variables* … … 2825 2802 (second (second args)) 2826 2803 var1 var2) 2827 (cond 2828 ((and (fixnump first) (fixnump second)) 2829 (dformat t "p2-numeric-comparison form = ~S~%" form) 2830 (if (funcall op first second) 2831 (emit-push-t) 2832 (emit-push-nil)) 2833 (return-from p2-numeric-comparison)) 2834 ((fixnump second) 2835 (dformat t "p2-numeric-comparison form = ~S~%" form) 2836 (compile-form (car args) :target :stack) 2837 (unless (single-valued-p first) 2838 (emit-clear-values)) 2839 (emit-push-constant-int second) 2840 (emit-invokevirtual +lisp-object-class+ 2841 (case op 2842 (< "isLessThan") 2843 (<= "isLessThanOrEqualTo") 2844 (> "isGreaterThan") 2845 (>= "isGreaterThanOrEqualTo") 2846 (= "isEqualTo") 2847 (/= "isNotEqualTo")) 2848 '("I") 2849 "Z") 2850 ;; Java boolean on stack here 2851 (let ((LABEL1 (gensym)) 2852 (LABEL2 (gensym))) 2853 (emit 'ifeq LABEL1) 2854 (emit-push-t) 2855 (emit 'goto LABEL2) 2856 (label LABEL1) 2857 (emit-push-nil) 2858 (label LABEL2) 2859 (emit-move-from-stack target)) 2860 (return-from p2-numeric-comparison)) 2861 ((and (setf var1 (unboxed-fixnum-variable first)) 2862 (setf var2 (unboxed-fixnum-variable second))) 2863 (dformat t "p2-numeric-comparison both unboxed var case form = ~S~%" form) 2864 (let ((LABEL1 (gensym)) 2865 (LABEL2 (gensym))) 2866 (emit 'iload (variable-register var1)) 2867 (emit 'iload (variable-register var2)) 2868 (emit (case op 2869 (< 'if_icmpge) 2870 (<= 'if_icmpgt) 2871 (> 'if_icmple) 2872 (>= 'if_icmplt) 2873 (= 'if_icmpne) 2874 (/= 'if_icmpeq)) 2875 LABEL1) 2876 (emit-push-t) 2877 (emit 'goto LABEL2) 2878 (label LABEL1) 2879 (emit-push-nil) 2880 (label LABEL2) 2881 (emit-move-from-stack target) 2882 (return-from p2-numeric-comparison)) 2883 ) 2884 ) ; cond 2885 )))) 2804 (cond ((and (fixnump first) (fixnump second)) 2805 (dformat t "p2-numeric-comparison form = ~S~%" form) 2806 (if (funcall op first second) 2807 (emit-push-t) 2808 (emit-push-nil)) 2809 (return-from p2-numeric-comparison)) 2810 ((fixnump second) 2811 (dformat t "p2-numeric-comparison form = ~S~%" form) 2812 (compile-form (car args) :target :stack) 2813 (unless (single-valued-p first) 2814 (emit-clear-values)) 2815 (emit-push-constant-int second) 2816 (emit-invokevirtual +lisp-object-class+ 2817 (case op 2818 (< "isLessThan") 2819 (<= "isLessThanOrEqualTo") 2820 (> "isGreaterThan") 2821 (>= "isGreaterThanOrEqualTo") 2822 (= "isEqualTo") 2823 (/= "isNotEqualTo")) 2824 '("I") 2825 "Z") 2826 ;; Java boolean on stack here 2827 (let ((LABEL1 (gensym)) 2828 (LABEL2 (gensym))) 2829 (emit 'ifeq LABEL1) 2830 (emit-push-t) 2831 (emit 'goto LABEL2) 2832 (label LABEL1) 2833 (emit-push-nil) 2834 (label LABEL2) 2835 (emit-move-from-stack target)) 2836 (return-from p2-numeric-comparison)) 2837 ((and (setf var1 (unboxed-fixnum-variable first)) 2838 (setf var2 (unboxed-fixnum-variable second))) 2839 (dformat t "p2-numeric-comparison both unboxed var case form = ~S~%" form) 2840 (let ((LABEL1 (gensym)) 2841 (LABEL2 (gensym))) 2842 (emit 'iload (variable-register var1)) 2843 (emit 'iload (variable-register var2)) 2844 (emit (case op 2845 (< 'if_icmpge) 2846 (<= 'if_icmpgt) 2847 (> 'if_icmple) 2848 (>= 'if_icmplt) 2849 (= 'if_icmpne) 2850 (/= 'if_icmpeq)) 2851 LABEL1) 2852 (emit-push-t) 2853 (emit 'goto LABEL2) 2854 (label LABEL1) 2855 (emit-push-nil) 2856 (label LABEL2) 2857 (emit-move-from-stack target) 2858 (return-from p2-numeric-comparison)))))))) 2886 2859 ;; Still here? 2887 (compile-function-call form target representation) 2888 ) 2860 (compile-function-call form target representation)) 2889 2861 2890 2862 (defun compile-test-3 (form negatep) 2891 ;; (dformat t "compile-test-3 form = ~S~%" form)2892 2863 (let ((op (car form)) 2893 2864 (args (cdr form))) … … 2963 2934 (second (second args)) 2964 2935 variable) 2965 (cond 2966 ((fixnump second) 2967 (compile-form first :target :stack) 2968 (maybe-emit-clear-values first) 2969 (emit-push-constant-int second) 2970 (emit-invokevirtual +lisp-object-class+ s '("I") "Z")) 2971 ((setf variable (unboxed-fixnum-variable second)) 2972 (compile-form first :target :stack) 2973 (maybe-emit-clear-values first) 2974 (aver (variable-register variable)) 2975 (emit 'iload (variable-register variable)) 2976 (emit-invokevirtual +lisp-object-class+ s '("I") "Z")) 2977 (t 2978 (process-args args) 2979 (emit-invokevirtual +lisp-object-class+ s (list +lisp-object+) "Z"))) 2936 (cond ((fixnump second) 2937 (compile-form first :target :stack) 2938 (maybe-emit-clear-values first) 2939 (emit-push-constant-int second) 2940 (emit-invokevirtual +lisp-object-class+ s '("I") "Z")) 2941 ((setf variable (unboxed-fixnum-variable second)) 2942 (compile-form first :target :stack) 2943 (maybe-emit-clear-values first) 2944 (aver (variable-register variable)) 2945 (emit 'iload (variable-register variable)) 2946 (emit-invokevirtual +lisp-object-class+ s '("I") "Z")) 2947 (t 2948 (process-args args) 2949 (emit-invokevirtual +lisp-object-class+ s (list +lisp-object+) "Z"))) 2980 2950 (return-from compile-test-3 (if negatep 'ifne 'ifeq)))))) 2981 2951 … … 3255 3225 (let ((initform (variable-initform variable))) 3256 3226 (cond (initform 3257 (cond 3258 ((and *trust-user-type-declarations* 3259 (variable-register variable) 3260 (variable-declared-type variable) 3261 (subtypep (variable-declared-type variable) 'FIXNUM)) 3262 (dformat t "p2-let-bindings declared fixnum case: ~S~%" 3263 (variable-name variable)) 3264 (setf (variable-representation variable) :unboxed-fixnum) 3265 (compile-form initform :target :stack :representation :unboxed-fixnum)) 3266 ((and (variable-register variable) 3267 (eql (variable-writes variable) 0) 3268 (subtypep (derive-type initform) 'FIXNUM)) 3269 (dformat t "p2-let-bindings read-only fixnum case: ~S~%" 3270 (variable-name variable)) 3271 (setf (variable-representation variable) :unboxed-fixnum) 3272 (compile-form initform :target :stack :representation :unboxed-fixnum)) 3273 (t 3274 (compile-form initform :target :stack))) 3227 (cond ((and *trust-user-type-declarations* 3228 (variable-register variable) 3229 (variable-declared-type variable) 3230 (subtypep (variable-declared-type variable) 'FIXNUM)) 3231 (dformat t "p2-let-bindings declared fixnum case: ~S~%" 3232 (variable-name variable)) 3233 (setf (variable-representation variable) :unboxed-fixnum) 3234 (compile-form initform :target :stack :representation :unboxed-fixnum)) 3235 ((and (variable-register variable) 3236 (eql (variable-writes variable) 0) 3237 (subtypep (derive-type initform) 'FIXNUM)) 3238 (dformat t "p2-let-bindings read-only fixnum case: ~S~%" 3239 (variable-name variable)) 3240 (setf (variable-representation variable) :unboxed-fixnum) 3241 (compile-form initform :target :stack :representation :unboxed-fixnum)) 3242 (t 3243 (compile-form initform :target :stack))) 3275 3244 (unless must-clear-values 3276 3245 (unless (single-valued-p initform) … … 3278 3247 (t 3279 3248 (emit-push-nil))) 3280 (cond 3281 ((variable-special-p variable) 3282 (emit-move-from-stack (setf (variable-temp-register variable) (allocate-register)))) 3283 ((eq (variable-representation variable) :unboxed-fixnum) 3284 (emit 'istore (variable-register variable))) 3285 (t 3286 (compile-binding variable))))) 3249 (cond ((variable-special-p variable) 3250 (emit-move-from-stack (setf (variable-temp-register variable) (allocate-register)))) 3251 ((eq (variable-representation variable) :unboxed-fixnum) 3252 (emit 'istore (variable-register variable))) 3253 (t 3254 (compile-binding variable))))) 3287 3255 (when must-clear-values 3288 3256 (emit-clear-values)) … … 3304 3272 (let* ((initform (variable-initform variable)) 3305 3273 (boundp nil)) 3306 (cond 3307 ((and (variable-special-p variable) 3308 (eq initform (variable-name variable))) 3309 (emit-push-current-thread) 3310 (emit 'getstatic 3311 *this-class* 3312 (declare-symbol (variable-name variable)) 3313 +lisp-symbol+) 3314 (emit-invokevirtual +lisp-thread-class+ 3315 "bindSpecialToCurrentValue" 3316 (list +lisp-symbol+) 3317 nil) 3318 (setf boundp t)) 3319 (initform 3320 (cond 3321 ((and *trust-user-type-declarations* 3322 (null (variable-closure-index variable)) 3323 (not (variable-special-p variable)) 3324 (variable-declared-type variable) 3325 (subtypep (variable-declared-type variable) 'FIXNUM)) 3326 (dformat t "p2-let*-bindings declared fixnum case~%") 3327 (setf (variable-representation variable) :unboxed-fixnum) 3328 (compile-form initform :target :stack :representation :unboxed-fixnum) 3329 (setf (variable-register variable) (allocate-register)) 3330 (emit 'istore (variable-register variable)) 3331 (setf boundp t)) 3332 ((and (null (variable-closure-index variable)) 3333 (not (variable-special-p variable)) 3334 (eql (variable-writes variable) 0) 3335 (subtypep (derive-type initform) 'FIXNUM)) 3336 (dformat t "p2-let*-bindings read-only fixnum case: ~S~%" 3337 (variable-name variable)) 3338 (setf (variable-representation variable) :unboxed-fixnum) 3339 (compile-form initform :target :stack :representation :unboxed-fixnum) 3340 (setf (variable-register variable) (allocate-register)) 3341 (emit 'istore (variable-register variable)) 3342 (setf boundp t)) 3343 (t 3344 (compile-form initform :target :stack))) 3345 (unless must-clear-values 3346 (unless (single-valued-p initform) 3347 (setf must-clear-values t)))) 3348 (t 3349 (emit-push-nil))) 3274 (cond ((and (variable-special-p variable) 3275 (eq initform (variable-name variable))) 3276 (emit-push-current-thread) 3277 (emit 'getstatic *this-class* 3278 (declare-symbol (variable-name variable)) +lisp-symbol+) 3279 (emit-invokevirtual +lisp-thread-class+ 3280 "bindSpecialToCurrentValue" 3281 (list +lisp-symbol+) 3282 nil) 3283 (setf boundp t)) 3284 (initform 3285 (cond ((and *trust-user-type-declarations* 3286 (null (variable-closure-index variable)) 3287 (not (variable-special-p variable)) 3288 (variable-declared-type variable) 3289 (subtypep (variable-declared-type variable) 'FIXNUM)) 3290 (dformat t "p2-let*-bindings declared fixnum case~%") 3291 (setf (variable-representation variable) :unboxed-fixnum) 3292 (compile-form initform :target :stack :representation :unboxed-fixnum) 3293 (setf (variable-register variable) (allocate-register)) 3294 (emit 'istore (variable-register variable)) 3295 (setf boundp t)) 3296 ((and (null (variable-closure-index variable)) 3297 (not (variable-special-p variable)) 3298 (eql (variable-writes variable) 0) 3299 (subtypep (derive-type initform) 'FIXNUM)) 3300 (dformat t "p2-let*-bindings read-only fixnum case: ~S~%" 3301 (variable-name variable)) 3302 (setf (variable-representation variable) :unboxed-fixnum) 3303 (compile-form initform :target :stack :representation :unboxed-fixnum) 3304 (setf (variable-register variable) (allocate-register)) 3305 (emit 'istore (variable-register variable)) 3306 (setf boundp t)) 3307 (t 3308 (compile-form initform :target :stack))) 3309 (unless must-clear-values 3310 (unless (single-valued-p initform) 3311 (setf must-clear-values t)))) 3312 (t 3313 (emit-push-nil))) 3350 3314 (unless (variable-special-p variable) 3351 3315 (unless (or (variable-closure-index variable) (variable-register variable)) … … 3449 3413 (emit 'getfield +lisp-go-class+ "tag" +lisp-object+) ; Stack depth is still 1. 3450 3414 (emit 'astore tag-register) 3451 3452 3415 (dolist (tag local-tags) 3453 3416 (let ((NEXT (gensym))) 3454 3417 (emit 'aload tag-register) 3455 (emit 'getstatic 3456 *this-class* 3418 (emit 'getstatic *this-class* 3457 3419 (if *compile-file-truename* 3458 3420 (declare-object-as-string (tag-label tag)) 3459 3421 (declare-object (tag-label tag))) 3460 3422 +lisp-object+) 3461 3462 3423 (emit 'if_acmpne NEXT) ;; Jump if not EQ. 3463 3424 ;; Restore dynamic environment. … … 3471 3432 (emit 'aload go-register) 3472 3433 (emit 'athrow) 3473 3474 3434 ;; Finally... 3475 3435 (push (make-handler :from BEGIN-BLOCK … … 3721 3681 (if (symbol-package obj) 3722 3682 (let ((g (declare-symbol obj))) 3723 (emit 'getstatic 3724 *this-class* 3725 g 3726 +lisp-symbol+)) 3683 (emit 'getstatic *this-class* g +lisp-symbol+)) 3727 3684 ;; An uninterned symbol. 3728 3685 (let ((g (if *compile-file-truename* 3729 3686 (declare-object-as-string obj) 3730 3687 (declare-object obj)))) 3731 (emit 'getstatic 3732 *this-class* 3733 g 3734 +lisp-object+))) 3688 (emit 'getstatic *this-class* g +lisp-object+))) 3735 3689 (emit-move-from-stack target)) 3736 3690 ((listp obj) … … 3738 3692 (declare-object-as-string obj) 3739 3693 (declare-object obj)))) 3740 (emit 'getstatic 3741 *this-class* 3742 g 3743 +lisp-object+) 3694 (emit 'getstatic *this-class* g +lisp-object+) 3744 3695 (emit-move-from-stack target))) 3745 3696 ((constantp obj) … … 3812 3763 (declare-local-function local-function) 3813 3764 (declare-object function)))) 3814 (emit 'getstatic 3815 *this-class* 3816 g 3817 +lisp-object+) 3765 (emit 'getstatic *this-class* g +lisp-object+) 3818 3766 (emit 'var-set (local-function-variable local-function)))) 3819 3767 (t … … 4134 4082 (var1 (unboxed-fixnum-variable arg1)) 4135 4083 (var2 (unboxed-fixnum-variable arg2))) 4136 (cond 4137 ((and (numberp arg1) (numberp arg2)) 4138 (compile-constant (+ arg1 arg2) 4139 :target target 4140 :representation representation)) 4141 ((and var1 var2) 4142 (dformat t "compile-plus case 1~%") 4143 (dformat t "target = ~S representation = ~S~%" target representation) 4144 (aver (variable-register var1)) 4145 (aver (variable-register var2)) 4146 (when target 4147 (cond 4148 ((eq representation :unboxed-fixnum) 4149 (emit-push-int var1) 4150 (emit-push-int arg2) 4151 (emit 'iadd)) 4152 (t 4153 (emit 'iload (variable-register var1)) 4154 (emit 'i2l) 4155 (emit 'iload (variable-register var2)) 4156 (emit 'i2l) 4157 (emit 'ladd) 4158 (emit-box-long))) 4159 (emit-move-from-stack target representation))) 4160 ((and var1 (fixnump arg2)) 4161 (dformat t "compile-plus case 2~%") 4162 (aver (variable-register var1)) 4163 (cond 4164 ((eq representation :unboxed-fixnum) 4165 (emit-push-int var1) 4166 (emit-push-int arg2) 4167 (emit 'iadd)) 4168 (t 4169 (emit-push-int var1) 4170 (emit 'i2l) 4171 (emit-push-int arg2) 4172 (emit 'i2l) 4173 (emit 'ladd) 4174 (emit-box-long))) 4175 (emit-move-from-stack target representation)) 4176 ((and (fixnump arg1) var2) 4177 (dformat t "compile-plus case 3~%") 4178 (aver (variable-register var2)) 4179 (cond 4180 ((eq representation :unboxed-fixnum) 4181 (emit-push-int arg1) 4182 (emit-push-int var2) 4183 (emit 'iadd)) 4184 (t 4185 (emit-push-int arg1) 4186 (emit 'i2l) 4187 (emit-push-int var2) 4188 (emit 'i2l) 4189 (emit 'ladd) 4190 (emit-box-long))) 4191 (emit-move-from-stack target representation)) 4192 ((eql arg1 1) 4193 (dformat t "compile-plus case 4~%") 4194 (compile-form arg2 :target :stack) 4195 (maybe-emit-clear-values arg2) 4196 (emit-invoke-method "incr" target representation)) 4197 ((eql arg2 1) 4198 (dformat t "compile-plus case 5~%") 4199 (compile-form arg1 :target :stack) 4200 (maybe-emit-clear-values arg1) 4201 (emit-invoke-method "incr" target representation)) 4202 ((arg-is-fixnum-p arg1) 4203 (dformat t "compile-plus case 6~%") 4204 (emit-push-int arg1) 4205 (compile-form arg2 :target :stack) 4206 (maybe-emit-clear-values arg2) 4207 (emit 'swap) 4208 (emit-invokevirtual +lisp-object-class+ "add" '("I") +lisp-object+) 4209 (when (eq representation :unboxed-fixnum) 4210 (emit-unbox-fixnum)) 4211 (emit-move-from-stack target representation)) 4212 ((arg-is-fixnum-p arg2) 4213 (dformat t "compile-plus case 7~%") 4214 (compile-form arg1 :target :stack) 4215 (maybe-emit-clear-values arg1) 4216 (emit-push-int arg2) 4217 (emit-invokevirtual +lisp-object-class+ "add" '("I") +lisp-object+) 4218 (when (eq representation :unboxed-fixnum) 4219 (emit-unbox-fixnum)) 4220 (emit-move-from-stack target representation)) 4221 (t 4222 (dformat t "compile-plus case 8~%") 4223 (compile-binary-operation "add" args target representation))))) 4084 (cond ((and (numberp arg1) (numberp arg2)) 4085 (compile-constant (+ arg1 arg2) 4086 :target target 4087 :representation representation)) 4088 ((and var1 var2) 4089 (dformat t "compile-plus case 1~%") 4090 (dformat t "target = ~S representation = ~S~%" target representation) 4091 (aver (variable-register var1)) 4092 (aver (variable-register var2)) 4093 (when target 4094 (cond ((eq representation :unboxed-fixnum) 4095 (emit-push-int var1) 4096 (emit-push-int arg2) 4097 (emit 'iadd)) 4098 (t 4099 (emit 'iload (variable-register var1)) 4100 (emit 'i2l) 4101 (emit 'iload (variable-register var2)) 4102 (emit 'i2l) 4103 (emit 'ladd) 4104 (emit-box-long))) 4105 (emit-move-from-stack target representation))) 4106 ((and var1 (fixnump arg2)) 4107 (dformat t "compile-plus case 2~%") 4108 (aver (variable-register var1)) 4109 (cond ((eq representation :unboxed-fixnum) 4110 (emit-push-int var1) 4111 (emit-push-int arg2) 4112 (emit 'iadd)) 4113 (t 4114 (emit-push-int var1) 4115 (emit 'i2l) 4116 (emit-push-int arg2) 4117 (emit 'i2l) 4118 (emit 'ladd) 4119 (emit-box-long))) 4120 (emit-move-from-stack target representation)) 4121 ((and (fixnump arg1) var2) 4122 (dformat t "compile-plus case 3~%") 4123 (aver (variable-register var2)) 4124 (cond ((eq representation :unboxed-fixnum) 4125 (emit-push-int arg1) 4126 (emit-push-int var2) 4127 (emit 'iadd)) 4128 (t 4129 (emit-push-int arg1) 4130 (emit 'i2l) 4131 (emit-push-int var2) 4132 (emit 'i2l) 4133 (emit 'ladd) 4134 (emit-box-long))) 4135 (emit-move-from-stack target representation)) 4136 ((eql arg1 1) 4137 (dformat t "compile-plus case 4~%") 4138 (compile-form arg2 :target :stack) 4139 (maybe-emit-clear-values arg2) 4140 (emit-invoke-method "incr" target representation)) 4141 ((eql arg2 1) 4142 (dformat t "compile-plus case 5~%") 4143 (compile-form arg1 :target :stack) 4144 (maybe-emit-clear-values arg1) 4145 (emit-invoke-method "incr" target representation)) 4146 ((arg-is-fixnum-p arg1) 4147 (dformat t "compile-plus case 6~%") 4148 (emit-push-int arg1) 4149 (compile-form arg2 :target :stack) 4150 (maybe-emit-clear-values arg2) 4151 (emit 'swap) 4152 (emit-invokevirtual +lisp-object-class+ "add" '("I") +lisp-object+) 4153 (when (eq representation :unboxed-fixnum) 4154 (emit-unbox-fixnum)) 4155 (emit-move-from-stack target representation)) 4156 ((arg-is-fixnum-p arg2) 4157 (dformat t "compile-plus case 7~%") 4158 (compile-form arg1 :target :stack) 4159 (maybe-emit-clear-values arg1) 4160 (emit-push-int arg2) 4161 (emit-invokevirtual +lisp-object-class+ "add" '("I") +lisp-object+) 4162 (when (eq representation :unboxed-fixnum) 4163 (emit-unbox-fixnum)) 4164 (emit-move-from-stack target representation)) 4165 (t 4166 (dformat t "compile-plus case 8~%") 4167 (compile-binary-operation "add" args target representation))))) 4224 4168 (4 4225 4169 (dformat t "compile-plus case 9~%") … … 4241 4185 (var1 (unboxed-fixnum-variable arg1)) 4242 4186 (var2 (unboxed-fixnum-variable arg2))) 4243 (cond 4244 ((and (numberp arg1) (numberp arg2)) 4245 (compile-constant (- arg1 arg2) 4246 :target target 4247 :representation representation)) 4248 ((and var1 var2) 4249 (dformat t "compile-minus case 1~%") 4250 (aver (variable-register var1)) 4251 (aver (variable-register var2)) 4252 (when target 4253 (cond 4254 ((eq representation :unboxed-fixnum) 4255 (emit 'iload (variable-register var1)) 4256 (emit 'iload (variable-register var2)) 4257 (emit 'isub)) 4258 (t 4259 (emit 'iload (variable-register var1)) 4260 (emit 'i2l) 4261 (emit 'iload (variable-register var2)) 4262 (emit 'i2l) 4263 (emit 'lsub) 4264 (emit-box-long))) 4265 (emit-move-from-stack target representation))) 4266 ((and var1 (fixnump arg2)) 4267 (dformat t "compile-minus case 2~%") 4268 (aver (variable-register var1)) 4269 (cond 4270 ((eq representation :unboxed-fixnum) 4271 (emit-push-int var1) 4272 (emit-push-int arg2) 4273 (emit 'isub)) 4274 (t 4275 (emit-push-int var1) 4276 (emit 'i2l) 4277 (emit-push-int arg2) 4278 (emit 'i2l) 4279 (emit 'lsub) 4280 (emit-box-long))) 4281 (emit-move-from-stack target representation)) 4282 ((and (fixnump arg1) var2) 4283 (dformat t "compile-minus case 3~%") 4284 (aver (variable-register var2)) 4285 (cond 4286 ((eq representation :unboxed-fixnum) 4287 (emit-push-int arg1) 4288 (emit-push-int var2) 4289 (emit 'isub)) 4290 (t 4291 (emit-push-int arg1) 4292 (emit 'i2l) 4293 (emit-push-int var2) 4294 (emit 'i2l) 4295 (emit 'lsub) 4296 (emit-box-long))) 4297 (emit-move-from-stack target representation)) 4298 ((eql arg2 1) 4299 (dformat t "compile-minus case 5~%") 4300 (compile-form arg1 :target :stack) 4301 (maybe-emit-clear-values arg2) 4302 (emit-invoke-method "decr" target representation)) 4303 ((arg-is-fixnum-p arg2) 4304 (dformat t "compile-minus case 7~%") 4305 (compile-form arg1 :target :stack) 4306 (maybe-emit-clear-values arg1) 4307 (emit-push-int arg2) 4308 (emit-invokevirtual +lisp-object-class+ "subtract" '("I") +lisp-object+) 4309 (when (eq representation :unboxed-fixnum) 4310 (emit-unbox-fixnum)) 4311 (emit-move-from-stack target representation)) 4312 (t 4313 (dformat t "compile-minus case 8~%") 4314 (compile-binary-operation "subtract" args target representation))))) 4187 (cond ((and (numberp arg1) (numberp arg2)) 4188 (compile-constant (- arg1 arg2) 4189 :target target 4190 :representation representation)) 4191 ((and var1 var2) 4192 (dformat t "compile-minus case 1~%") 4193 (aver (variable-register var1)) 4194 (aver (variable-register var2)) 4195 (when target 4196 (cond 4197 ((eq representation :unboxed-fixnum) 4198 (emit 'iload (variable-register var1)) 4199 (emit 'iload (variable-register var2)) 4200 (emit 'isub)) 4201 (t 4202 (emit 'iload (variable-register var1)) 4203 (emit 'i2l) 4204 (emit 'iload (variable-register var2)) 4205 (emit 'i2l) 4206 (emit 'lsub) 4207 (emit-box-long))) 4208 (emit-move-from-stack target representation))) 4209 ((and var1 (fixnump arg2)) 4210 (dformat t "compile-minus case 2~%") 4211 (aver (variable-register var1)) 4212 (cond 4213 ((eq representation :unboxed-fixnum) 4214 (emit-push-int var1) 4215 (emit-push-int arg2) 4216 (emit 'isub)) 4217 (t 4218 (emit-push-int var1) 4219 (emit 'i2l) 4220 (emit-push-int arg2) 4221 (emit 'i2l) 4222 (emit 'lsub) 4223 (emit-box-long))) 4224 (emit-move-from-stack target representation)) 4225 ((and (fixnump arg1) var2) 4226 (dformat t "compile-minus case 3~%") 4227 (aver (variable-register var2)) 4228 (cond ((eq representation :unboxed-fixnum) 4229 (emit-push-int arg1) 4230 (emit-push-int var2) 4231 (emit 'isub)) 4232 (t 4233 (emit-push-int arg1) 4234 (emit 'i2l) 4235 (emit-push-int var2) 4236 (emit 'i2l) 4237 (emit 'lsub) 4238 (emit-box-long))) 4239 (emit-move-from-stack target representation)) 4240 ((eql arg2 1) 4241 (dformat t "compile-minus case 5~%") 4242 (compile-form arg1 :target :stack) 4243 (maybe-emit-clear-values arg2) 4244 (emit-invoke-method "decr" target representation)) 4245 ((arg-is-fixnum-p arg2) 4246 (dformat t "compile-minus case 7~%") 4247 (compile-form arg1 :target :stack) 4248 (maybe-emit-clear-values arg1) 4249 (emit-push-int arg2) 4250 (emit-invokevirtual +lisp-object-class+ "subtract" '("I") +lisp-object+) 4251 (when (eq representation :unboxed-fixnum) 4252 (emit-unbox-fixnum)) 4253 (emit-move-from-stack target representation)) 4254 (t 4255 (dformat t "compile-minus case 8~%") 4256 (compile-binary-operation "subtract" args target representation))))) 4315 4257 (4 4316 4258 (dformat t "compile-minus case 9~%") … … 4426 4368 4427 4369 (defun compile-special-reference (name target representation) 4428 (emit 'getstatic 4429 *this-class* 4430 (declare-symbol name) 4431 +lisp-symbol+) 4370 (emit 'getstatic *this-class* (declare-symbol name) +lisp-symbol+) 4432 4371 (emit-push-current-thread) 4433 (emit-invokevirtual +lisp-symbol-class+ 4434 "symbolValue" 4435 (list +lisp-thread+) 4436 +lisp-object+) 4372 (emit-invokevirtual +lisp-symbol-class+ "symbolValue" 4373 (list +lisp-thread+) +lisp-object+) 4437 4374 (when (eq representation :unboxed-fixnum) 4438 4375 (emit-unbox-fixnum)) … … 4730 4667 (error "COMPILE-FORM unhandled case ~S" form))))) 4731 4668 ((symbolp form) 4732 ;; (dformat t "compile-form symbolp case form = ~S~%" form) 4733 (cond 4734 ((null form) 4735 (emit-push-nil) 4736 (emit-move-from-stack target)) 4737 ((eq form t) 4738 (emit-push-t) 4739 (emit-move-from-stack target)) 4740 ((keywordp form) 4741 (emit 'getstatic *this-class* (declare-keyword form) +lisp-symbol+) 4742 (emit-move-from-stack target)) 4743 (t 4744 ;; Maybe it's a symbol macro... 4745 (let ((expansion (macroexpand form))) 4746 (if (eq expansion form) 4747 (compile-variable-reference form target representation) 4748 (compile-form expansion :target target :representation representation)))))) 4669 (cond ((null form) 4670 (emit-push-nil) 4671 (emit-move-from-stack target)) 4672 ((eq form t) 4673 (emit-push-t) 4674 (emit-move-from-stack target)) 4675 ((keywordp form) 4676 (emit 'getstatic *this-class* (declare-keyword form) +lisp-symbol+) 4677 (emit-move-from-stack target)) 4678 (t 4679 ;; Maybe it's a symbol macro... 4680 (let ((expansion (macroexpand form))) 4681 (if (eq expansion form) 4682 (compile-variable-reference form target representation) 4683 (compile-form expansion :target target :representation representation)))))) 4749 4684 ((block-node-p form) 4750 4685 (cond ((equal (block-name form) '(TAGBODY)) … … 4780 4715 (get-descriptor (list +lisp-object-array+) 4781 4716 +lisp-object+)))) 4782 (cond 4783 (*closure-variables* 4784 (return-from analyze-args 4785 (cond ((<= arg-count 4) 4786 (get-descriptor (list* +lisp-object-array+ 4787 (make-list arg-count :initial-element +lisp-object+)) 4788 +lisp-object+)) 4789 (t (setf *using-arg-array* t) 4790 (setf *arity* arg-count) 4791 (get-descriptor (list +lisp-object-array+ +lisp-object-array+) 4792 +lisp-object+))))) 4793 (t 4794 (return-from analyze-args 4795 (cond ((<= arg-count 4) 4796 (get-descriptor (make-list arg-count :initial-element +lisp-object+) 4797 +lisp-object+)) 4798 (t (setf *using-arg-array* t) 4799 (setf *arity* arg-count) 4800 (get-descriptor (list +lisp-object-array+) 4801 +lisp-object+))))))) 4717 (cond (*closure-variables* 4718 (return-from analyze-args 4719 (cond ((<= arg-count 4) 4720 (get-descriptor (list* +lisp-object-array+ 4721 (make-list arg-count :initial-element +lisp-object+)) 4722 +lisp-object+)) 4723 (t (setf *using-arg-array* t) 4724 (setf *arity* arg-count) 4725 (get-descriptor (list +lisp-object-array+ +lisp-object-array+) 4726 +lisp-object+))))) 4727 (t 4728 (return-from analyze-args 4729 (cond ((<= arg-count 4) 4730 (get-descriptor (make-list arg-count :initial-element +lisp-object+) 4731 +lisp-object+)) 4732 (t (setf *using-arg-array* t) 4733 (setf *arity* arg-count) 4734 (get-descriptor (list +lisp-object-array+) 4735 +lisp-object+))))))) 4802 4736 (when (or (memq '&KEY args) 4803 4737 (memq '&OPTIONAL args) … … 5067 5001 (aver (eql (compiland-closure-register compiland) 1)) 5068 5002 (when (some #'variable-closure-index parameters) 5069 (emit 'aload (compiland-closure-register compiland))) 5070 ) 5003 (emit 'aload (compiland-closure-register compiland)))) 5071 5004 (t 5072 5005 (emit-push-constant-int (length *closure-variables*)) … … 5077 5010 (when (variable-closure-index variable) 5078 5011 (dformat t "moving variable ~S~%" (variable-name variable)) 5079 (cond 5080 ((variable-register variable) 5081 ;; (aver (variable-register variable)) ;; FIXME need to handle the arg-array case too! 5082 (when (eql (variable-register variable) (compiland-closure-register compiland)) 5083 (error "ERROR! compiland closure register = ~S var ~S register = ~S~%" 5084 (compiland-closure-register compiland) 5085 (variable-name variable) 5086 (variable-register variable))) 5087 (emit 'dup) ; array 5088 (emit-push-constant-int (variable-closure-index variable)) 5089 (emit 'aload (variable-register variable)) 5090 (emit 'aastore) 5091 (setf (variable-register variable) nil) ; The variable has moved. 5092 ) 5093 ((variable-index variable) 5094 ;; (aver (null (compiland-parent compiland))) ;; FIXME 5095 (emit 'dup) ; array 5096 (emit-push-constant-int (variable-closure-index variable)) 5097 (emit 'aload (compiland-argument-register compiland)) 5098 (emit-push-constant-int (variable-index variable)) 5099 (emit 'aaload) 5100 (emit 'aastore) 5101 (setf (variable-index variable) nil) ; The variable has moved. 5102 ) 5103 ))) 5012 (cond ((variable-register variable) 5013 (when (eql (variable-register variable) 5014 (compiland-closure-register compiland)) 5015 (error "ERROR! compiland closure register = ~S var ~S register = ~S~%" 5016 (compiland-closure-register compiland) 5017 (variable-name variable) 5018 (variable-register variable))) 5019 (emit 'dup) ; array 5020 (emit-push-constant-int (variable-closure-index variable)) 5021 (emit 'aload (variable-register variable)) 5022 (emit 'aastore) 5023 (setf (variable-register variable) nil)) ; The variable has moved. 5024 ((variable-index variable) 5025 (emit 'dup) ; array 5026 (emit-push-constant-int (variable-closure-index variable)) 5027 (emit 'aload (compiland-argument-register compiland)) 5028 (emit-push-constant-int (variable-index variable)) 5029 (emit 'aaload) 5030 (emit 'aastore) 5031 (setf (variable-index variable) nil))))) ; The variable has moved. 5104 5032 (aver (not (null (compiland-closure-register compiland)))) 5105 5033 (cond (*child-p* … … 5109 5037 (emit 'astore (compiland-closure-register compiland)))) 5110 5038 (dformat t "~S done moving arguments to closure array~%" 5111 (compiland-name compiland)) 5112 ) 5039 (compiland-name compiland))) 5113 5040 5114 5041 ;; Establish dynamic bindings for any variables declared special. … … 5117 5044 (cond ((variable-register variable) 5118 5045 (emit-push-current-thread) 5119 (emit 'getstatic 5120 *this-class* 5046 (emit 'getstatic *this-class* 5121 5047 (declare-symbol (variable-name variable)) 5122 5048 +lisp-symbol+) 5123 5049 (emit 'aload (variable-register variable)) 5124 (emit-invokevirtual +lisp-thread-class+ 5125 "bindSpecial" 5126 (list +lisp-symbol+ +lisp-object+) 5127 nil) 5050 (emit-invokevirtual +lisp-thread-class+ "bindSpecial" 5051 (list +lisp-symbol+ +lisp-object+) nil) 5128 5052 (setf (variable-register variable) nil)) 5129 5053 ((variable-index variable) 5130 5054 (emit-push-current-thread) 5131 (emit 'getstatic 5132 *this-class* 5133 (declare-symbol (variable-name variable)) 5134 +lisp-symbol+) 5055 (emit 'getstatic *this-class* 5056 (declare-symbol (variable-name variable)) +lisp-symbol+) 5135 5057 (emit 'aload 1) 5136 5058 (emit 'bipush (variable-index variable)) 5137 5059 (emit 'aaload) 5138 (emit-invokevirtual +lisp-thread-class+ 5139 "bindSpecial" 5140 (list +lisp-symbol+ +lisp-object+) 5141 nil) 5060 (emit-invokevirtual +lisp-thread-class+ "bindSpecial" 5061 (list +lisp-symbol+ +lisp-object+) nil) 5142 5062 (setf (variable-index variable) nil))))) 5143 5063 … … 5172 5092 (emit 'astore (compiland-argument-register compiland))) 5173 5093 5174 (cond 5175 ((and (not *child-p*) (not *using-arg-array*)) 5176 (dolist (variable (reverse *visible-variables*)) 5177 (when (eq (variable-representation variable) :unboxed-fixnum) 5178 (emit 'aload (variable-register variable)) 5179 (emit-unbox-fixnum) 5180 (emit 'istore (variable-register variable)))))) 5094 (cond ((and (not *child-p*) (not *using-arg-array*)) 5095 (dolist (variable (reverse *visible-variables*)) 5096 (when (eq (variable-representation variable) :unboxed-fixnum) 5097 (emit 'aload (variable-register variable)) 5098 (emit-unbox-fixnum) 5099 (emit 'istore (variable-register variable)))))) 5181 5100 5182 5101 (maybe-initialize-thread-var) … … 5340 5259 (setf (fdefinition name) (sys::make-macro name compiled-definition)) 5341 5260 (setf (fdefinition name) compiled-definition))) 5342 (cond 5343 ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*)) 5344 (setf warnings-p nil failure-p nil)) 5345 ((zerop (+ jvm::*errors* jvm::*warnings*)) 5346 (setf failure-p nil))) 5261 (cond ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*)) 5262 (setf warnings-p nil failure-p nil)) 5263 ((zerop (+ jvm::*errors* jvm::*warnings*)) 5264 (setf failure-p nil))) 5347 5265 (when *compile-print* 5348 5266 (if name
Note: See TracChangeset
for help on using the changeset viewer.