Changeset 3838


Ignore:
Timestamp:
Mar 18, 2006, 6:25:16 AM (14 years ago)
Author:
gb
Message:

Do %TYPE-OF for x8664.

File:
1 edited

Legend:

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

    r3567 r3838  
    697697
    698698
     699
    699700#+x8664-target
    700 (eval-when (:compile-toplevel)
    701   (warn "Need %type-of support for x8664."))
    702 
    703 
     701(progn
     702(defparameter *nodeheader-0-types*
     703  #(function-vector
     704    symbol-vector
     705    catch-frame
     706    hash-vector
     707    pool
     708    population
     709    package
     710    slot-vector
     711    lisp-thread                         ;8
     712    vector-header
     713    bogus
     714    bogus
     715    bogus
     716    bogus
     717    bogus
     718    bogus
     719    ))
     720
     721(defparameter *nodeheader-1-types*
     722  #(ratio
     723    complex
     724    instance
     725    struct
     726    istruct
     727    value-cell
     728    xfunction
     729    lock                                ;7
     730    array-header
     731    simple-vector
     732    bogus
     733    bogus
     734    bogus
     735    bogus
     736    bogus
     737    bogus
     738    ))
     739
     740(defparameter *immheader-0-types*
     741  #(bogus
     742    bogus
     743    bogus
     744    bogus
     745    bogus
     746    bogus
     747    bogus
     748    bogus
     749    bogus
     750    bogus
     751    simple-signed-word-vector
     752    simple-unsigned-word-vector
     753    simple-base-string
     754    simple-signed-byte-vector
     755    simple-unsigned-byte-vector
     756    bit-vector))
     757
     758(defparameter *immheader-1-types*
     759  #(bignum
     760    double-float
     761    xcode-vector
     762    bogus
     763    bogus
     764    bogus
     765    bogus
     766    bogus
     767    bogus
     768    bogus
     769    bogus
     770    bogus
     771    bogus
     772    simple-signed-long-vector
     773    simple-unsigned-long-vector
     774    single-float-vector))
     775
     776(defparameter *immheader-2-types*
     777  #(macptr
     778    dead-macptr
     779    bogus
     780    bogus
     781    bogus
     782    bogus
     783    bogus
     784    bogus
     785    bogus
     786    bogus
     787    bogus
     788    bogus
     789    bogus
     790    simple-signed-doubleword-vector
     791    simple-unsigned-doubleword-vector
     792    double-float-vector))
     793
     794
     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))))
     820 
     821(defun %type-of (thing)
     822  (let* ((fulltag (fulltag thing))
     823         (high4 (ash (the fixnum (%lisp-lowbyte-ref thing)) (- x8664::ntagbits))))
     824    (declare (fixnum fulltag high4))
     825    (if (= fulltag x8664::fulltag-function)
     826      (let ((bits (lfun-bits thing)))
     827        (declare (fixnum bits))
     828        (if (logbitp $lfbits-trampoline-bit bits)
     829          (if (logbitp $lfbits-evaluated-bit bits)
     830            'interpreted-lexical-closure
     831            (let ((inner-fn (closure-function thing)))
     832              (if (neq inner-fn thing)
     833                (let ((inner-bits (lfun-bits inner-fn)))
     834                  (if (logbitp $lfbits-method-bit inner-bits)
     835                    'compiled-lexical-closure
     836                    (if (logbitp $lfbits-gfn-bit inner-bits)
     837                      'standard-generic-function ; not precisely - see class-of
     838                      (if (logbitp  $lfbits-cm-bit inner-bits)
     839                        'combined-method
     840                        'compiled-lexical-closure))))
     841                'compiled-lexical-closure)))
     842          (if (logbitp $lfbits-evaluated-bit bits)
     843            (if (logbitp $lfbits-method-bit bits)
     844              'interpreted-method-function
     845              'interpreted-function)
     846            (if (logbitp  $lfbits-method-bit bits)
     847              'method-function         
     848              'compiled-function))))
     849      (%svref (%svref *x8664-fulltag-types* fulltag) high4))))
     850
     851);#+x8664-target
     852     
    704853
    705854;;; real machine specific huh
Note: See TracChangeset for help on using the changeset viewer.