Ignore:
Timestamp:
Mar 30, 2006, 9:47:14 AM (14 years ago)
Author:
gb
Message:

%TYPE-OF fixes for x8664.

We haven't had interpreted functions for a few years.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/level-0/l0-pred.lisp

    r3885 r3931  
    485485                      (declare (fixnum bits))
    486486                      (if (logbitp $lfbits-trampoline-bit bits)
    487                         (if (logbitp $lfbits-evaluated-bit bits)
    488                           'interpreted-lexical-closure
    489                           (let ((inner-fn (closure-function thing)))
    490                             (if (neq inner-fn thing)
    491                               (let ((inner-bits (lfun-bits inner-fn)))
    492                                 (if (logbitp $lfbits-method-bit inner-bits)
    493                                   'compiled-lexical-closure
    494                                   (if (logbitp $lfbits-gfn-bit inner-bits)
    495                                     'standard-generic-function ; not precisely - see class-of
    496                                     (if (logbitp  $lfbits-cm-bit inner-bits)
    497                                       'combined-method
    498                                       'compiled-lexical-closure))))
    499                               'compiled-lexical-closure)))
    500                         (if (logbitp $lfbits-evaluated-bit bits)
    501                           (if (logbitp $lfbits-method-bit bits)
    502                             'interpreted-method-function
    503                             'interpreted-function)
    504                           (if (logbitp  $lfbits-method-bit bits)
    505                             'method-function         
    506                             'compiled-function))))
     487                        (let ((inner-fn (closure-function thing)))
     488                          (if (neq inner-fn thing)
     489                            (let ((inner-bits (lfun-bits inner-fn)))
     490                              (if (logbitp $lfbits-method-bit inner-bits)
     491                                'compiled-lexical-closure
     492                                (if (logbitp $lfbits-gfn-bit inner-bits)
     493                                  'standard-generic-function ; not precisely - see class-of
     494                                  (if (logbitp  $lfbits-cm-bit inner-bits)
     495                                    'combined-method
     496                                    'compiled-lexical-closure))))
     497                            'compiled-lexical-closure))
     498                        (if (logbitp  $lfbits-method-bit bits)
     499                          'method-function         
     500                          'compiled-function)))
    507501                    (if (eq type 'lock)
    508502                      (or (uvref thing ppc32::lock.kind-cell)
     
    669663                                   (declare (fixnum bits))
    670664                                   (if (logbitp $lfbits-trampoline-bit bits)
    671                                      (if (logbitp $lfbits-evaluated-bit bits)
    672                                        'interpreted-lexical-closure
    673                                        (let ((inner-fn (closure-function thing)))
     665                                     (let ((inner-fn (closure-function thing)))
    674666                                         (if (neq inner-fn thing)
    675667                                           (let ((inner-bits (lfun-bits inner-fn)))
     
    681673                                                   'combined-method
    682674                                                   'compiled-lexical-closure))))
    683                                            'compiled-lexical-closure)))
    684                                      (if (logbitp $lfbits-evaluated-bit bits)
    685                                        (if (logbitp $lfbits-method-bit bits)
    686                                          'interpreted-method-function
    687                                          'interpreted-function)
    688                                        (if (logbitp  $lfbits-method-bit bits)
    689                                          'method-function         
    690                                          'compiled-function)))))
     675                                           'compiled-lexical-closure))
     676                                     (if (logbitp  $lfbits-method-bit bits)
     677                                       'method-function         
     678                                       'compiled-function))))
    691679                                ((eq type 'lock)
    692680                                 (or (uvref thing ppc64::lock.kind-cell)
     
    723711    ratio
    724712    complex
    725     struct
     713    structure
    726714    istruct
    727715    value-cell
     
    793781
    794782
    795 (defparameter *x8664-fulltag-types* ())
    796 (setq *x8664-fulltag-types*
    797   (let* ((fixnums #16(fixnum))
    798          (tra #16(tagged-return-address)))
    799     (vector fixnums
    800             #(single-float immediate immediate immediate
    801               immediate immediate immediate immediate
    802               immediate immediate immediate immediate
    803               immediate immediate immediate immediate)
    804             #(base-char immediate immediate immediate
    805               immediate immediate immediate immediate
    806               immediate immediate immediate immediate
    807               immediate immediate immediate immediate)
    808             #16(list)
    809             tra
    810             *nodeheader-0-types*
    811             *nodeheader-1-types*
    812             *immheader-0-types*
    813             fixnums
    814             *immheader-1-types*
    815             *immheader-2-types*
    816             #16(null)
    817             tra
    818             #16(bogus)
    819             #16(symbol))))
     783(defparameter *x8664-%type-of-functions* nil)
     784
     785(let* ((fixnum (lambda (x) (declare (ignore x)) 'fixnum))
     786       (tra (lambda (x) (declare (ignore x)) 'tagged-return-address))
     787       (bogus (lambda (x) (declare (ignore x)) 'bogus)))
     788  (setq *x8664-%type-of-functions*
     789        (vector
     790         fixnum                         ;0
     791         (lambda (x) (declare (ignore x)) 'short-float) ;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 (unsigned-byte 8) typecode)
     807                                (type (unsigned-byte 4) low4 high4))
     808                       (let* ((name
     809                               (cond ((= low4 x8664::fulltag-immheader-0)
     810                                      (%svref *immheader-0-types* high4))
     811                                     ((= low4 x8664::fulltag-immheader-1)
     812                                      (%svref *immheader-1-types* high4))
     813                                     ((= low4 x8664::fulltag-immheader-2)
     814                                      (%svref *immheader-2-types* high4))
     815                                     ((= low4 x8664::fulltag-nodeheader-0)
     816                                      (%svref *nodeheader-0-types* high4))
     817                                     ((= low4 x8664::fulltag-nodeheader-1)
     818                                      (%svref *nodeheader-1-types* high4))
     819                                     (t 'bogus))))
     820                         (or (and (eq name 'lock)
     821                                  (uvref x x8664::lock.kind-cell))
     822                             name)))) ;13
     823         (lambda (x) (declare (ignore x)) 'symbol) ;14
     824         (lambda (thing)
     825           (let ((bits (lfun-bits thing)))
     826             (declare (fixnum bits))
     827             (if (logbitp $lfbits-trampoline-bit bits)
     828               (let ((inner-fn (closure-function thing)))
     829                 (if (neq inner-fn thing)
     830                   (let ((inner-bits (lfun-bits inner-fn)))
     831                     (if (logbitp $lfbits-method-bit inner-bits)
     832                       'compiled-lexical-closure
     833                       (if (logbitp $lfbits-gfn-bit inner-bits)
     834                         'standard-generic-function ; not precisely - see class-of
     835                         (if (logbitp  $lfbits-cm-bit inner-bits)
     836                           'combined-method
     837                           'compiled-lexical-closure))))
     838                   'compiled-lexical-closure))
     839               (if (logbitp  $lfbits-method-bit bits)
     840                 'method-function         
     841                 'compiled-function))))))) ;15
     842                                     
     843       
     844
     845
    820846 
    821847(defun %type-of (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::fulltag-nodeheader-0)
    828                                  (ash 1 x8664::fulltag-nodeheader-1)
    829                                  (ash 1 x8664::fulltag-immheader-0)
    830                                  (ash 1 x8664::fulltag-immheader-1)
    831                                  (ash 1 x8664::fulltag-immheader-2)))
    832       (%svref (%svref *x8664-fulltag-types* fulltag) high4)
    833       (if (= lisp x8664::tag-function)
    834         (let ((bits (lfun-bits thing)))
    835           (declare (fixnum bits))
    836           (if (logbitp $lfbits-trampoline-bit bits)
    837             (if (logbitp $lfbits-evaluated-bit bits)
    838               'interpreted-lexical-closure
    839               (let ((inner-fn (closure-function thing)))
    840                 (if (neq inner-fn thing)
    841                   (let ((inner-bits (lfun-bits inner-fn)))
    842                     (if (logbitp $lfbits-method-bit inner-bits)
    843                       'compiled-lexical-closure
    844                       (if (logbitp $lfbits-gfn-bit inner-bits)
    845                         'standard-generic-function ; not precisely - see class-of
    846                         (if (logbitp  $lfbits-cm-bit inner-bits)
    847                           'combined-method
    848                           'compiled-lexical-closure))))
    849                   'compiled-lexical-closure)))
    850             (if (logbitp $lfbits-evaluated-bit bits)
    851               (if (logbitp $lfbits-method-bit bits)
    852                 'interpreted-method-function
    853                 'interpreted-function)
    854               (if (logbitp  $lfbits-method-bit bits)
    855                 'method-function         
    856                 'compiled-function))))
    857         (%svref (%svref *x8664-fulltag-types* fulltag)
    858                 (the fixnum (ash (%lisp-lowbyte-ref thing)
    859                                  (- x8664::ntagbits))))))))
     848  (let* ((f (fulltag thing)))
     849    (funcall (%svref *x8664-%type-of-functions* f) thing)))
     850
    860851       
    861852
Note: See TracChangeset for help on using the changeset viewer.