Ignore:
Timestamp:
Jun 3, 2005, 2:03:18 PM (14 years ago)
Author:
gb
Message:

%TYPE-OF for PPC64.

File:
1 edited

Legend:

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

    r1596 r1627  
    415415    simple-signed-byte-vector           ; 25
    416416    simple-base-string                  ; 26
    417     *unused*                            ; 27
     417    bogus                               ; 27
    418418    simple-unsigned-word-vector         ; 28
    419419    simple-signed-word-vector           ; 29
     
    476476                      type)))))))))))
    477477
     478#+ppc64-target
     479(defparameter *immheader-types*
     480  #(bogus
     481    bogus
     482    code-vector
     483    bogus
     484    bogus
     485    bogus
     486    xcode-vector
     487    macptr
     488    bogus
     489    bogus
     490    bignum
     491    dead-macptr
     492    bogus
     493    bogus
     494    double-float
     495    bogus
     496    bogus
     497    bogus
     498    bogus
     499    bogus
     500    bogus
     501    bogus
     502    bogus
     503    bogus
     504    bogus
     505    bogus
     506    bogus
     507    bogus
     508    bogus
     509    bogus
     510    bogus
     511    bogus
     512    bogus
     513    bogus
     514    bogus
     515    bogus
     516    simple-signed-byte-vector
     517    simple-signed-word-vector
     518    simple-signed-long-vector
     519    simple-signed-doubleword-vector
     520    simple-unsigned-byte-vector
     521    simple-unsigned-word-vector
     522    simple-unsigned-long-vector
     523    simple-unsigned-doubleword-vector
     524    bogus
     525    bogus
     526    simple-short-float-vector
     527    bogus
     528    bogus
     529    bogus
     530    bogus
     531    simple-double-float-vector
     532    simple-base-string
     533    bogus
     534    bogus
     535    bogus
     536    bogus
     537    bogus
     538    bogus
     539    bogus
     540    bogus
     541    simple-bit-vector
     542    bogus
     543    bogus))
     544
     545#+ppc64-target
     546(defparameter *nodeheader-types*
     547    #(function
     548      catch-frame
     549      slot-vector
     550      bogus
     551      symbol
     552      lisp-thread
     553      standard-instance
     554      bogus
     555      bogus
     556      lock
     557      structure
     558      bogus
     559      bogus
     560      hash-vector
     561      internal-structure
     562      bogus
     563      bogus
     564      pool
     565      value-cell
     566      bogus
     567      bogus
     568      population
     569      xfunction
     570      bogus
     571      bogus
     572      package
     573      ratio
     574      bogus
     575      bogus
     576      svar
     577      complex
     578      bogus
     579      bogus
     580      array-header
     581      vector-header
     582      simple-vector
     583      bogus
     584      bogus
     585      bogus
     586      bogus
     587      bogus
     588      bogus
     589      bogus
     590      bogus
     591      bogus
     592      bogus
     593      bogus
     594      bogus
     595      bogus
     596      bogus
     597      bogus
     598      bogus
     599      bogus
     600      bogus
     601      bogus
     602      bogus
     603      bogus
     604      bogus
     605      bogus
     606      bogus
     607      bogus
     608      bogus
     609      bogus
     610      bogus
     611      )
     612  )
     613
     614#+ppc64-target
     615(defun %type-of (thing)
     616  (let* ((typecode (typecode thing)))
     617    (declare (fixnum typecode))
     618    (cond ((= typecode ppc64::tag-fixnum) 'fixnum)
     619          ((= typecode ppc64::fulltag-cons) 'cons)
     620          ((= typecode ppc64::subtag-character) 'character)
     621          ((= typecode ppc64::subtag-single-float) 'short-float)
     622          (t (let* ((lowtag (logand typecode ppc64::lowtagmask)))
     623               (declare (fixnum lowtag))
     624               (cond ((= lowtag ppc64::lowtag-immheader)
     625                       (%svref *immheader-types* (ash typecode -2)))
     626                      ((= lowtag ppc64::lowtag-nodeheader)
     627                       (let* ((type (%svref *nodeheader-types*
     628                                            (ash typecode -2))))
     629                         (cond ((eq type 'function)
     630                                (let ((bits (lfun-bits thing)))
     631                                  (declare (fixnum bits))
     632                                  (if (logbitp $lfbits-trampoline-bit bits)
     633                                    (if (logbitp $lfbits-evaluated-bit bits)
     634                                      'interpreted-lexical-closure
     635                                      (let ((inner-fn (closure-function thing)))
     636                                        (if (neq inner-fn thing)
     637                                          (let ((inner-bits (lfun-bits inner-fn)))
     638                                            (if (logbitp $lfbits-method-bit inner-bits)
     639                                              'compiled-lexical-closure
     640                                              (if (logbitp $lfbits-gfn-bit inner-bits)
     641                                                'standard-generic-function ; not precisely - see class-of
     642                                                (if (logbitp  $lfbits-cm-bit inner-bits)
     643                                                  'combined-method
     644                                                  'compiled-lexical-closure))))
     645                                          'compiled-lexical-closure)))
     646                                    (if (logbitp $lfbits-evaluated-bit bits)
     647                                      (if (logbitp $lfbits-method-bit bits)
     648                                        'interpreted-method-function
     649                                        'interpreted-function)
     650                                      (if (logbitp  $lfbits-method-bit bits)
     651                                        'method-function         
     652                                        'compiled-function)))))
     653                               ((eq type 'lock)
     654                                (or (uvref thing ppc64::lock.kind-cell)
     655                                    type))
     656                               (t type))))
     657                      (t 'immediate)))))))
     658
    478659
    479660;;; real machine specific huh
Note: See TracChangeset for help on using the changeset viewer.