Changeset 3931 for trunk/ccl/level0/l0pred.lisp
 Timestamp:
 Mar 30, 2006, 9:47:14 AM (14 years ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

trunk/ccl/level0/l0pred.lisp
r3885 r3931 485 485 (declare (fixnum bits)) 486 486 (if (logbitp $lfbitstrampolinebit bits) 487 (if (logbitp $lfbitsevaluatedbit bits) 488 'interpretedlexicalclosure 489 (let ((innerfn (closurefunction thing))) 490 (if (neq innerfn thing) 491 (let ((innerbits (lfunbits innerfn))) 492 (if (logbitp $lfbitsmethodbit innerbits) 493 'compiledlexicalclosure 494 (if (logbitp $lfbitsgfnbit innerbits) 495 'standardgenericfunction ; not precisely  see classof 496 (if (logbitp $lfbitscmbit innerbits) 497 'combinedmethod 498 'compiledlexicalclosure)))) 499 'compiledlexicalclosure))) 500 (if (logbitp $lfbitsevaluatedbit bits) 501 (if (logbitp $lfbitsmethodbit bits) 502 'interpretedmethodfunction 503 'interpretedfunction) 504 (if (logbitp $lfbitsmethodbit bits) 505 'methodfunction 506 'compiledfunction)))) 487 (let ((innerfn (closurefunction thing))) 488 (if (neq innerfn thing) 489 (let ((innerbits (lfunbits innerfn))) 490 (if (logbitp $lfbitsmethodbit innerbits) 491 'compiledlexicalclosure 492 (if (logbitp $lfbitsgfnbit innerbits) 493 'standardgenericfunction ; not precisely  see classof 494 (if (logbitp $lfbitscmbit innerbits) 495 'combinedmethod 496 'compiledlexicalclosure)))) 497 'compiledlexicalclosure)) 498 (if (logbitp $lfbitsmethodbit bits) 499 'methodfunction 500 'compiledfunction))) 507 501 (if (eq type 'lock) 508 502 (or (uvref thing ppc32::lock.kindcell) … … 669 663 (declare (fixnum bits)) 670 664 (if (logbitp $lfbitstrampolinebit bits) 671 (if (logbitp $lfbitsevaluatedbit bits) 672 'interpretedlexicalclosure 673 (let ((innerfn (closurefunction thing))) 665 (let ((innerfn (closurefunction thing))) 674 666 (if (neq innerfn thing) 675 667 (let ((innerbits (lfunbits innerfn))) … … 681 673 'combinedmethod 682 674 'compiledlexicalclosure)))) 683 'compiledlexicalclosure))) 684 (if (logbitp $lfbitsevaluatedbit bits) 685 (if (logbitp $lfbitsmethodbit bits) 686 'interpretedmethodfunction 687 'interpretedfunction) 688 (if (logbitp $lfbitsmethodbit bits) 689 'methodfunction 690 'compiledfunction))))) 675 'compiledlexicalclosure)) 676 (if (logbitp $lfbitsmethodbit bits) 677 'methodfunction 678 'compiledfunction)))) 691 679 ((eq type 'lock) 692 680 (or (uvref thing ppc64::lock.kindcell) … … 723 711 ratio 724 712 complex 725 struct 713 structure 726 714 istruct 727 715 valuecell … … 793 781 794 782 795 (defparameter *x8664fulltagtypes* ()) 796 (setq *x8664fulltagtypes* 797 (let* ((fixnums #16(fixnum)) 798 (tra #16(taggedreturnaddress))) 799 (vector fixnums 800 #(singlefloat immediate immediate immediate 801 immediate immediate immediate immediate 802 immediate immediate immediate immediate 803 immediate immediate immediate immediate) 804 #(basechar immediate immediate immediate 805 immediate immediate immediate immediate 806 immediate immediate immediate immediate 807 immediate immediate immediate immediate) 808 #16(list) 809 tra 810 *nodeheader0types* 811 *nodeheader1types* 812 *immheader0types* 813 fixnums 814 *immheader1types* 815 *immheader2types* 816 #16(null) 817 tra 818 #16(bogus) 819 #16(symbol)))) 783 (defparameter *x8664%typeoffunctions* nil) 784 785 (let* ((fixnum (lambda (x) (declare (ignore x)) 'fixnum)) 786 (tra (lambda (x) (declare (ignore x)) 'taggedreturnaddress)) 787 (bogus (lambda (x) (declare (ignore x)) 'bogus))) 788 (setq *x8664%typeoffunctions* 789 (vector 790 fixnum ;0 791 (lambda (x) (declare (ignore x)) 'shortfloat) ;1 792 (lambda (x) (if (characterp x) 'character 'immediate)) ;2 793 (lambda (x) (declare (ignore x)) 'cons) ;3 794 tra ;4 795 bogus ;5 796 bogus ;6 797 bogus ;7 798 fixnum ;8 799 bogus ;9 800 bogus ;10 801 (lambda (x) (declare (ignore x)) 'null) ;11 802 tra ;12 803 (lambda (x) (let* ((typecode (typecode x)) 804 (low4 (logand typecode x8664::fulltagmask)) 805 (high4 (ash typecode ( x8664::ntagbits)))) 806 (declare (type (unsignedbyte 8) typecode) 807 (type (unsignedbyte 4) low4 high4)) 808 (let* ((name 809 (cond ((= low4 x8664::fulltagimmheader0) 810 (%svref *immheader0types* high4)) 811 ((= low4 x8664::fulltagimmheader1) 812 (%svref *immheader1types* high4)) 813 ((= low4 x8664::fulltagimmheader2) 814 (%svref *immheader2types* high4)) 815 ((= low4 x8664::fulltagnodeheader0) 816 (%svref *nodeheader0types* high4)) 817 ((= low4 x8664::fulltagnodeheader1) 818 (%svref *nodeheader1types* high4)) 819 (t 'bogus)))) 820 (or (and (eq name 'lock) 821 (uvref x x8664::lock.kindcell)) 822 name)))) ;13 823 (lambda (x) (declare (ignore x)) 'symbol) ;14 824 (lambda (thing) 825 (let ((bits (lfunbits thing))) 826 (declare (fixnum bits)) 827 (if (logbitp $lfbitstrampolinebit bits) 828 (let ((innerfn (closurefunction thing))) 829 (if (neq innerfn thing) 830 (let ((innerbits (lfunbits innerfn))) 831 (if (logbitp $lfbitsmethodbit innerbits) 832 'compiledlexicalclosure 833 (if (logbitp $lfbitsgfnbit innerbits) 834 'standardgenericfunction ; not precisely  see classof 835 (if (logbitp $lfbitscmbit innerbits) 836 'combinedmethod 837 'compiledlexicalclosure)))) 838 'compiledlexicalclosure)) 839 (if (logbitp $lfbitsmethodbit bits) 840 'methodfunction 841 'compiledfunction))))))) ;15 842 843 844 845 820 846 821 847 (defun %typeof (thing) 822 (let* ((lisptag (lisptag thing)) 823 (typecode (typecode thing)) 824 (high4 (ash typecode ( x8664::ntagbits)))) 825 (declare (type (mod 8) lisptag) 826 (type (mod 256) typecode)) 827 (if (logbitp lisptag (logior (ash 1 x8664::fulltagnodeheader0) 828 (ash 1 x8664::fulltagnodeheader1) 829 (ash 1 x8664::fulltagimmheader0) 830 (ash 1 x8664::fulltagimmheader1) 831 (ash 1 x8664::fulltagimmheader2))) 832 (%svref (%svref *x8664fulltagtypes* fulltag) high4) 833 (if (= lisp x8664::tagfunction) 834 (let ((bits (lfunbits thing))) 835 (declare (fixnum bits)) 836 (if (logbitp $lfbitstrampolinebit bits) 837 (if (logbitp $lfbitsevaluatedbit bits) 838 'interpretedlexicalclosure 839 (let ((innerfn (closurefunction thing))) 840 (if (neq innerfn thing) 841 (let ((innerbits (lfunbits innerfn))) 842 (if (logbitp $lfbitsmethodbit innerbits) 843 'compiledlexicalclosure 844 (if (logbitp $lfbitsgfnbit innerbits) 845 'standardgenericfunction ; not precisely  see classof 846 (if (logbitp $lfbitscmbit innerbits) 847 'combinedmethod 848 'compiledlexicalclosure)))) 849 'compiledlexicalclosure))) 850 (if (logbitp $lfbitsevaluatedbit bits) 851 (if (logbitp $lfbitsmethodbit bits) 852 'interpretedmethodfunction 853 'interpretedfunction) 854 (if (logbitp $lfbitsmethodbit bits) 855 'methodfunction 856 'compiledfunction)))) 857 (%svref (%svref *x8664fulltagtypes* fulltag) 858 (the fixnum (ash (%lisplowbyteref thing) 859 ( x8664::ntagbits)))))))) 848 (let* ((f (fulltag thing))) 849 (funcall (%svref *x8664%typeoffunctions* f) thing))) 850 860 851 861 852
Note: See TracChangeset
for help on using the changeset viewer.