source: branches/arm/level-0/l0-pred.lisp @ 13841

Last change on this file since 13841 was 13841, checked in by gb, 9 years ago

Use PPC32 version of %TYPE-OF on ARM, too.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 36.7 KB
RevLine 
[6]1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
[13067]3;;;   Copyright (C) 2009 Clozure Associates
[6]4;;;   Copyright (C) 1994-2001 Digitool, Inc
[13066]5;;;   This file is part of Clozure CL. 
[6]6;;;
[13066]7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
[6]9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
[13066]10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
[6]11;;;   conflict, the preamble takes precedence. 
12;;;
[13066]13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
[6]14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
[1937]18(in-package "CCL")
[6]19
20;; Non-portable type-predicates & such.
21
22
23;; bootstrapping defs - real ones in l1-typesys, l1-clos, sysutils
24
25(defun find-builtin-cell (type &optional create)
26  (declare (ignore create))
27  (cons type nil))
28
29
30(defun builtin-typep (form cell)
[7724]31  (typep form (class-cell-name cell)))
[6]32
33(defun class-cell-typep (arg class-cell)
[7724]34  (typep arg (class-cell-name class-cell)))
[6]35
36(defun class-cell-find-class (class-cell errorp)
37  (declare (ignore errorp)) ; AARGH can't be right
38  ;(dbg-paws #x100)
[7724]39  (let ((class (and class-cell (class-cell-class class-cell))))
[6]40    (or class 
41        (if  (fboundp 'find-class)
[7724]42          (find-class (class-cell-name class-cell) nil)))))
[6]43
44(defun %require-type-builtin (form foo)
45  (declare (ignore foo))
46  form)
47
48(defun %require-type-class-cell (form cell)
49  (declare (ignore cell))
50  form)
51 
52(defun non-nil-symbol-p (x)
53  (if (symbolp x) x))
54
55(defun pathnamep (thing)
56  (or (istruct-typep thing 'pathname) (istruct-typep thing 'logical-pathname)))
57
58(defun compiled-function-p (form)
[929]59  "Return true if OBJECT is a COMPILED-FUNCTION, and NIL otherwise."
[6]60  (and (functionp form)
61       (not (logbitp $lfbits-trampoline-bit (the fixnum (lfun-bits form))))))
62
[1418]63;;; all characters are base-chars.
[6]64(defun extended-char-p (c)
65  (declare (ignore c)))
66
67
[1418]68;;; Some of these things are probably open-coded.
69;;; The functions have to exist SOMEWHERE ...
[6]70(defun fixnump (x)
[1596]71  (= (the fixnum (lisptag x)) target::tag-fixnum))
[6]72
73(defun bignump (x)
[1596]74  (= (the fixnum (typecode x)) target::subtag-bignum))
[6]75
76(defun integerp (x)
[929]77  "Return true if OBJECT is an INTEGER, and NIL otherwise."
[6]78  (let* ((typecode (typecode x)))
79    (declare (fixnum typecode))
[1596]80    (or (= typecode target::tag-fixnum)
81        (= typecode target::subtag-bignum))))
[6]82
83(defun ratiop (x)
[1596]84  (= (the fixnum (typecode x)) target::subtag-ratio))
[6]85
86
87(defun rationalp (x)
[929]88  "Return true if OBJECT is a RATIONAL, and NIL otherwise."
[6]89  (or (fixnump x)
90      (let* ((typecode (typecode x)))
91        (declare (fixnum typecode))
[13789]92        #+(or ppc32-target x8632-target arm-target)
[10159]93        (and (>= typecode target::min-numeric-subtag)
94             (<= typecode target::max-rational-subtag))
[3437]95        #+(or ppc64-target x8664-target)
96        (cond ((= typecode target::subtag-bignum) t)
97              ((= typecode target::subtag-ratio) t)))))
[6]98
99(defun short-float-p (x)
[1596]100  (= (the fixnum (typecode x)) target::subtag-single-float))
[6]101
102
103(defun double-float-p (x)
[1596]104  (= (the fixnum (typecode x)) target::subtag-double-float))
[6]105
106(defun floatp (x)
[929]107  "Return true if OBJECT is a FLOAT, and NIL otherwise."
[6]108  (let* ((typecode (typecode x)))
109    (declare (fixnum typecode))
[1596]110    (or (= typecode target::subtag-single-float)
111        (= typecode target::subtag-double-float))))
[6]112
113(defun realp (x)
[929]114  "Return true if OBJECT is a REAL, and NIL otherwise."
[6]115  (let* ((typecode (typecode x)))
116    (declare (fixnum typecode))
[13789]117    #+(or ppc32-target x8632-target arm-target)
[10159]118    (or (= typecode target::tag-fixnum)
119        (and (>= typecode target::min-numeric-subtag)
120             (<= typecode target::max-real-subtag)))
[1596]121    #+ppc64-target
[1996]122    (if (<= typecode ppc64::subtag-double-float)
123      (logbitp (the (integer 0 #.ppc64::subtag-double-float) typecode)
124               (logior (ash 1 ppc64::tag-fixnum)
125                       (ash 1 ppc64::subtag-single-float)
126                       (ash 1 ppc64::subtag-double-float)
127                       (ash 1 ppc64::subtag-bignum)
[3437]128                       (ash 1 ppc64::subtag-ratio))))
129    #+x8664-target
[8987]130    (if (<= typecode x8664::subtag-double-float)
[3437]131      (logbitp (the (integer 0 #.x8664::subtag-double-float) typecode)
132               (logior (ash 1 x8664::tag-fixnum)
133                       (ash 1 x8664::subtag-bignum)
134                       (ash 1 x8664::tag-single-float)
135                       (ash 1 x8664::subtag-double-float)
136                       (ash 1 x8664::subtag-ratio))))))
[6]137
138(defun complexp (x)
[929]139  "Return true if OBJECT is a COMPLEX, and NIL otherwise."
[1596]140  (= (the fixnum (typecode x)) target::subtag-complex))
[6]141
142(defun numberp (x)
[929]143  "Return true if OBJECT is a NUMBER, and NIL otherwise."
[6]144  (let* ((typecode (typecode x)))
145    (declare (fixnum typecode))
[13789]146    #+(or ppc32-target x8632-target arm-target)
[10159]147    (or (= typecode target::tag-fixnum)
148        (and (>= typecode target::min-numeric-subtag)
149             (<= typecode target::max-numeric-subtag)))
[1596]150    #+ppc64-target
[1996]151    (if (<= typecode ppc64::subtag-double-float)
152      (logbitp (the (integer 0 #.ppc64::subtag-double-float) typecode)
153               (logior (ash 1 ppc64::tag-fixnum)
154                       (ash 1 ppc64::subtag-bignum)
155                       (ash 1 ppc64::subtag-single-float)
156                       (ash 1 ppc64::subtag-double-float)
157                       (ash 1 ppc64::subtag-ratio)
[3437]158                       (ash 1 ppc64::subtag-complex))))
159    #+x8664-target
160    (if (< typecode x8664::nbits-in-word)
161      (logbitp (the (integer 0 #.x8664::subtag-double-float) typecode)
162               (logior (ash 1 x8664::tag-fixnum)
163                       (ash 1 x8664::subtag-bignum)
164                       (ash 1 x8664::tag-single-float)
165                       (ash 1 x8664::subtag-double-float)
166                       (ash 1 x8664::subtag-ratio)
167                       (ash 1 x8664::subtag-complex))))
168   
169    ))
[6]170
171(defun arrayp (x)
[929]172  "Return true if OBJECT is an ARRAY, and NIL otherwise."
[1596]173  (>= (the fixnum (typecode x)) target::min-array-subtag))
[6]174
175(defun vectorp (x)
[929]176  "Return true if OBJECT is a VECTOR, and NIL otherwise."
[1596]177  (>= (the fixnum (typecode x)) target::min-vector-subtag))
[6]178
179
180(defun stringp (x)
[929]181  "Return true if OBJECT is a STRING, and NIL otherwise."
[6]182  (let* ((typecode (typecode x)))
183    (declare (fixnum typecode))
[1596]184    (if (= typecode target::subtag-vectorH)
185      (setq typecode (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref x target::arrayH.flags-cell)))))
186    (= typecode target::subtag-simple-base-string)))
[6]187
188
189(defun simple-base-string-p (x)
[1596]190  (= (the fixnum (typecode x)) target::subtag-simple-base-string))
[6]191
192(defun simple-string-p (x)
[929]193  "Return true if OBJECT is a SIMPLE-STRING, and NIL otherwise."
[1596]194  (= (the fixnum (typecode x)) target::subtag-simple-base-string))
[6]195
196(defun complex-array-p (x)
197  (let* ((typecode (typecode x)))
198    (declare (fixnum typecode))
[1596]199    (if (or (= typecode target::subtag-arrayH)
200            (= typecode target::subtag-vectorH))
[6]201      (not (%array-header-simple-p x)))))
202
203(defun simple-array-p (thing)
204  "Returns T if the object is a simple array, else returns NIL.
205   That's why it's called SIMPLE-ARRAY-P.  Get it ?
206   A simple-array may have no fill-pointer, may not be displaced,
207   and may not be adjustable."
208  (let* ((typecode (typecode thing)))
209    (declare (fixnum typecode))
[1596]210    (if (or (= typecode target::subtag-arrayH)
211            (= typecode target::subtag-vectorH))
[6]212      (%array-header-simple-p thing)
[1596]213      (> typecode target::subtag-vectorH))))
[6]214
215(defun macptrp (x)
[1596]216  (= (the fixnum (typecode x)) target::subtag-macptr))
[6]217
[7578]218(defun dead-macptr-p (x)
219  (= (the fixnum (typecode x)) target::subtag-dead-macptr))
[6]220
[7578]221
[1418]222;;; Note that this is true of symbols and functions and many other
223;;; things that it wasn't true of on the 68K.
[6]224(defun gvectorp (x)
[13789]225  #+(or ppc32-target x8632-target arm-target)
[10159]226  (= (the fixnum (logand (the fixnum (typecode x)) target::fulltagmask)) target::fulltag-nodeheader)
[1596]227  #+ppc64-target
[3437]228  (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-nodeheader)
229  #+x8664-target
230  (let* ((fulltag (logand (the fixnum (typecode x)) x8664::fulltagmask)))
231    (declare (fixnum fulltag))
232    (or (= fulltag x8664::fulltag-nodeheader-0)
233        (= fulltag x8664::fulltag-nodeheader-1)))
234  )
[6]235
[1596]236
[6]237(setf (type-predicate 'gvector) 'gvectorp)
238
[964]239(defun ivectorp (x)
[13789]240  #+(or ppc32-target x8632-target arm-target)
[10159]241  (= (the fixnum (logand (the fixnum (typecode x)) target::fulltagmask))
242     target::fulltag-immheader)
[1596]243  #+ppc64-target
[3437]244  (= (the fixnum (logand (the fixnum (typecode x)) ppc64::lowtagmask)) ppc64::lowtag-immheader)
245  #+x8664-target
246  (let* ((fulltag (logand (the fixnum (typecode x)) x8664::fulltagmask)))
247    (declare (fixnum fulltag))
248    (or (= fulltag x8664::fulltag-immheader-0)
249        (= fulltag x8664::fulltag-immheader-1)
250        (= fulltag x8664::fulltag-immheader-2)))
251  )
[964]252
253(setf (type-predicate 'ivector) 'ivectorp)
254
[6]255(defun miscobjp (x)
[13789]256  #+(or ppc32-target x8632-target x8664-target arm-target)
[3437]257  (= (the fixnum (lisptag x)) target::tag-misc)
[1558]258  #+ppc64-target
259  (= (the fixnum (fulltag x)) ppc64::fulltag-misc)
260  )
[6]261
262(defun simple-vector-p (x)
[929]263  "Return true if OBJECT is a SIMPLE-VECTOR, and NIL otherwise."
[1596]264  (= (the fixnum (typecode x)) target::subtag-simple-vector))
[6]265
266(defun base-string-p (thing)
267  (let* ((typecode (typecode thing)))
268    (declare (fixnum typecode))
[1596]269    (or (= typecode target::subtag-simple-base-string)
270        (and (= typecode target::subtag-vectorh)
[6]271             (= (the fixnum 
[1596]272                  (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref thing target::arrayH.flags-cell))))
273                target::subtag-simple-base-string)))))
[6]274
275(defun simple-bit-vector-p (form)
[929]276  "Return true if OBJECT is a SIMPLE-BIT-VECTOR, and NIL otherwise."
[1596]277  (= (the fixnum (typecode form)) target::subtag-bit-vector))
[6]278
279(defun bit-vector-p (thing)
[929]280  "Return true if OBJECT is a BIT-VECTOR, and NIL otherwise."
[6]281  (let* ((typecode (typecode thing)))
282    (declare (fixnum typecode))
[1596]283    (or (= typecode target::subtag-bit-vector)
284        (and (= typecode target::subtag-vectorh)
[6]285             (= (the fixnum 
[1596]286                  (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref thing target::arrayH.flags-cell))))
287                target::subtag-bit-vector)))))
[6]288
289(defun displaced-array-p (array)
290  (if (%array-is-header array)
[1596]291    (do* ((disp (%svref array target::arrayH.displacement-cell)
292                (+ disp (the fixnum (%svref target target::arrayH.displacement-cell))))
293          (target (%svref array target::arrayH.data-vector-cell)
294                  (%svref target target::arrayH.data-vector-cell)))
[309]295         ((not (%array-is-header target))
296          (values target disp)))
[6]297    (values nil 0)))
298
299
300
[929]301(defun eq (x y)
302  "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
303  (eq x y))
[6]304
305
306(defun cons-equal (x y)
307  (declare (cons x y))
308  (if (equal (car x) (car y))
309    (equal (cdr x) (cdr y))))
310
311(defun hairy-equal (x y)
312  (declare (optimize (speed 3)))
[1326]313  ;; X and Y are not EQL, and are both of tag target::fulltag-misc.
[6]314  (let* ((x-type (typecode x))
315         (y-type (typecode y)))
316    (declare (fixnum x-type y-type))
[1326]317    (if (and (>= x-type target::subtag-vectorH)
318             (>= y-type target::subtag-vectorH))
319        (let* ((x-simple (if (= x-type target::subtag-vectorH)
320                             (ldb target::arrayH.flags-cell-subtag-byte 
321                                  (the fixnum (%svref x target::arrayH.flags-cell)))
[6]322                             x-type))
[1326]323               (y-simple (if (= y-type target::subtag-vectorH)
324                             (ldb target::arrayH.flags-cell-subtag-byte 
325                                  (the fixnum (%svref y target::arrayH.flags-cell)))
[6]326                             y-type)))
327          (declare (fixnum x-simple y-simple))
[1326]328          (if (= x-simple target::subtag-simple-base-string)
329              (if (= y-simple target::subtag-simple-base-string)
[6]330                  (locally
331                      (declare (optimize (speed 3) (safety 0)))
[1326]332                    (let* ((x-len (if (= x-type target::subtag-vectorH) 
333                                      (%svref x target::vectorH.logsize-cell)
[6]334                                      (uvsize x)))
335                           (x-pos 0)
[1326]336                           (y-len (if (= y-type target::subtag-vectorH) 
337                                      (%svref y target::vectorH.logsize-cell)
[6]338                                      (uvsize y)))
339                           (y-pos 0))
340                      (declare (fixnum x-len x-pos y-len y-pos))
[1326]341                      (when (= x-type target::subtag-vectorH)
[6]342                        (multiple-value-setq (x x-pos) (array-data-and-offset x)))
[1326]343                      (when (= y-type target::subtag-vectorH)
[6]344                        (multiple-value-setq (y y-pos) (array-data-and-offset y)))
345                      (%simple-string= x y x-pos y-pos (the fixnum (+ x-pos x-len)) (the fixnum (+ y-pos y-len))))))
346              ;;Bit-vector case or fail.
[1326]347              (and (= x-simple target::subtag-bit-vector)
348                   (= y-simple target::subtag-bit-vector)
[6]349                   (locally
350                       (declare (optimize (speed 3) (safety 0)))
[1326]351                     (let* ((x-len (if (= x-type target::subtag-vectorH) 
352                                       (%svref x target::vectorH.logsize-cell)
[6]353                                       (uvsize x)))
354                            (x-pos 0)
[1326]355                            (y-len (if (= y-type target::subtag-vectorH) 
356                                       (%svref y target::vectorH.logsize-cell)
[6]357                                       (uvsize y)))
358                            (y-pos 0))
359                       (declare (fixnum x-len x-pos y-len y-pos))
360                       (when (= x-len y-len)
[1326]361                         (when (= x-type target::subtag-vectorH)
[6]362                           (multiple-value-setq (x x-pos) (array-data-and-offset x)))
[1326]363                         (when (= y-type target::subtag-vectorH)
[6]364                           (multiple-value-setq (y y-pos) (array-data-and-offset y)))
365                         (do* ((i 0 (1+ i)))
366                              ((= i x-len) t)
367                           (declare (fixnum i))
368                           (unless (= (the bit (sbit x x-pos)) (the bit (sbit y y-pos)))
369                             (return))
370                           (incf x-pos)
371                           (incf y-pos))))))))
372        (if (= x-type y-type)
[1326]373            (if (= x-type target::subtag-istruct)
[10309]374                (and (let* ((structname (istruct-cell-name (%svref x 0))))
375                       (and (eq structname (istruct-cell-name (%svref y 0)))
[6]376                            (or (eq structname 'pathname)
[5671]377                                (eq structname 'logical-pathname)))
378                       (locally
379                           (declare (optimize (speed 3) (safety 0)))
[10870]380                         (let* ((x-size (uvsize x))
381                                (skip (if (eq structname 'pathname)
382                                        %physical-pathname-version
383                                        -1)))
384                           (declare (fixnum x-size skip))
[5671]385                           (when (= x-size (the fixnum (uvsize y)))
[11639]386                             (if *case-sensitive-filesystem*
387                               (do* ((i 1 (1+ i)))
388                                    ((= i x-size) t)
389                                 (declare (fixnum i))
390                                 (unless (or (= i skip)
391                                             (equal (%svref x i) (%svref y i)))
392                                   (return)))
393                                                              (do* ((i 1 (1+ i)))
394                                    ((= i x-size) t)
395                                 (declare (fixnum i))
396                                 (unless (or (= i skip)
397                                             (equalp (%svref x i) (%svref y i)))
398                                   (return))))))))))))))
[6]399
[13841]400#+(or ppc32-target arm-target)
[3437]401(progn
[6]402(defparameter *nodeheader-types*
403  #(bogus                               ; 0
404    ratio                               ; 1
405    bogus                               ; 2
406    complex                             ; 3
407    catch-frame                         ; 4
408    function                            ; 5
[7624]409    basic-stream                         ; 6
[6]410    symbol                              ; 7
411    lock                                ; 8
412    hash-table-vector                   ; 9
413    pool                                ; 10
414    population                          ; 11
415    package                             ; 12
416    slot-vector                         ; 13
417    standard-instance                   ; 14
418    structure                           ; 15
419    internal-structure                  ; 16
420    value-cell                          ; 17
421    xfunction                           ; 18
[4594]422    array-header                        ; 19
423    vector-header                       ; 20
424    simple-vector                       ; 21
425    bogus                               ; 22
[6]426    bogus                               ; 23
427    bogus                               ; 24
428    bogus                               ; 25
429    bogus                               ; 26
430    bogus                               ; 27
431    bogus                               ; 28
432    bogus                               ; 29
433    bogus                               ; 30
434    bogus                               ; 31
435    ))
436
[3437]437
[6]438(defparameter *immheader-types*
439  #(bignum                              ; 0
440    short-float                         ; 1
441    double-float                        ; 2
442    macptr                              ; 3
443    dead-macptr                         ; 4
444    code-vector                         ; 5
445    creole-object                       ; 6
[4594]446    ;; 8-19 are unused
[1326]447    xcode-vector                        ; 7
[6]448    bogus                               ; 8
449    bogus                               ; 9
450    bogus                               ; 10
451    bogus                               ; 11
452    bogus                               ; 12
453    bogus                               ; 13
454    bogus                               ; 14
455    bogus                               ; 15
456    bogus                               ; 16
457    bogus                               ; 17
458    bogus                               ; 18
459    bogus                               ; 19
[4594]460    simple-short-float-vector           ; 20
461    simple-unsigned-long-vector         ; 21
462    simple-signed-long-vector           ; 22
[5091]463    simple-fixnum-vector                ; 23
[5389]464    simple-base-string                  ; 24
[4594]465    simple-unsigned-byte-vector         ; 25
466    simple-signed-byte-vector           ; 26
[5389]467    bogus                               ; 27
[6]468    simple-unsigned-word-vector         ; 28
469    simple-signed-word-vector           ; 29
470    simple-double-float-vector          ; 30
471    simple-bit-vector                   ; 31
472    ))
473
474(defun %type-of (thing)
475  (let* ((typecode (typecode thing)))
476    (declare (fixnum typecode))
[13841]477    (if (= typecode target::tag-fixnum)
[6]478      'fixnum
[13841]479      (if (= typecode target::tag-list)
[6]480        (if thing 'cons 'null)
[13841]481        (if (= typecode target::tag-imm)
[6]482          (if (base-char-p thing)
483            'base-char
484            'immediate)
[13841]485          (if (= typecode target::subtag-macptr)
[163]486            (if (classp thing)
487              (class-name thing)
488              'macptr)
[13841]489            (let* ((tag-type (logand typecode target::full-tag-mask))
490                   (tag-val (ash typecode (- target::ntagbits))))
[163]491              (declare (fixnum tag-type tag-val))
[13841]492              (if (/= tag-type target::fulltag-nodeheader)
[163]493                (%svref *immheader-types* tag-val)
494                (let ((type (%svref *nodeheader-types* tag-val)))
495                  (if (eq type 'function)
496                    (let ((bits (lfun-bits thing)))
497                      (declare (fixnum bits))
498                      (if (logbitp $lfbits-trampoline-bit bits)
[3931]499                        (let ((inner-fn (closure-function thing)))
500                          (if (neq inner-fn thing)
501                            (let ((inner-bits (lfun-bits inner-fn)))
502                              (if (logbitp $lfbits-method-bit inner-bits)
503                                'compiled-lexical-closure
504                                (if (logbitp $lfbits-gfn-bit inner-bits)
505                                  'standard-generic-function ; not precisely - see class-of
506                                  (if (logbitp  $lfbits-cm-bit inner-bits)
507                                    'combined-method
508                                    'compiled-lexical-closure))))
509                            'compiled-lexical-closure))
510                        (if (logbitp  $lfbits-method-bit bits)
511                          'method-function         
512                          'compiled-function)))
[163]513                    (if (eq type 'lock)
[13841]514                      (or (uvref thing target::lock.kind-cell)
[163]515                          type)
516                      type)))))))))))
[6]517
[13841]518);#+(or ppc32-target arm-target)
[3437]519
[1627]520#+ppc64-target
[3437]521(progn
[1627]522(defparameter *immheader-types*
523  #(bogus
524    bogus
525    code-vector
526    bogus
527    bogus
528    bogus
529    xcode-vector
530    macptr
531    bogus
532    bogus
533    bignum
534    dead-macptr
535    bogus
536    bogus
537    double-float
538    bogus
539    bogus
540    bogus
541    bogus
542    bogus
543    bogus
544    bogus
545    bogus
546    bogus
547    bogus
548    bogus
549    bogus
550    bogus
551    bogus
552    bogus
553    bogus
554    bogus
555    bogus
556    bogus
557    bogus
558    bogus
559    simple-signed-byte-vector
560    simple-signed-word-vector
561    simple-signed-long-vector
562    simple-signed-doubleword-vector
563    simple-unsigned-byte-vector
564    simple-unsigned-word-vector
565    simple-unsigned-long-vector
566    simple-unsigned-doubleword-vector
567    bogus
568    bogus
569    simple-short-float-vector
[4651]570    simple-fixnum-vector
[1627]571    bogus
572    bogus
573    bogus
574    simple-double-float-vector
575    bogus
576    bogus
[5389]577    simple-base-string
[1627]578    bogus
579    bogus
580    bogus
581    bogus
582    bogus
[5389]583    bogus
[1627]584    simple-bit-vector
585    bogus
586    bogus))
[6]587
[1627]588(defparameter *nodeheader-types*
589    #(function
590      catch-frame
591      slot-vector
[1996]592      ratio
[1627]593      symbol
[7624]594      basic-stream
[1627]595      standard-instance
[1996]596      complex
[1627]597      bogus
598      lock
599      structure
600      bogus
601      bogus
602      hash-vector
603      internal-structure
604      bogus
605      bogus
606      pool
607      value-cell
608      bogus
609      bogus
610      population
611      xfunction
612      bogus
613      bogus
614      package
615      bogus
616      bogus
[1996]617      bogus
[1627]618      bogus
619      bogus
[1996]620      bogus
[2666]621      bogus
[1627]622      array-header
623      vector-header
624      simple-vector
625      bogus
626      bogus
627      bogus
628      bogus
629      bogus
630      bogus
631      bogus
632      bogus
633      bogus
634      bogus
635      bogus
636      bogus
637      bogus
638      bogus
639      bogus
640      bogus
641      bogus
642      bogus
643      bogus
644      bogus
645      bogus
646      bogus
647      bogus
648      bogus
649      bogus
650      bogus
651      bogus
652      bogus
653      )
654  )
655
[3437]656
[1627]657(defun %type-of (thing)
[3437]658  (if (null thing)
659    'null
660    (let* ((typecode (typecode thing)))
661      (declare (fixnum typecode))
662      (cond ((= typecode ppc64::tag-fixnum) 'fixnum)
663            ((= typecode ppc64::fulltag-cons) 'cons)
664            ((= typecode ppc64::subtag-character) 'character)
665            ((= typecode ppc64::subtag-single-float) 'short-float)
666            (t (let* ((lowtag (logand typecode ppc64::lowtagmask)))
667                 (declare (fixnum lowtag))
668                 (cond ((= lowtag ppc64::lowtag-immheader)
669                        (%svref *immheader-types* (ash typecode -2)))
670                       ((= lowtag ppc64::lowtag-nodeheader)
671                        (let* ((type (%svref *nodeheader-types*
672                                             (ash typecode -2))))
673                          (cond ((eq type 'function)
674                                 (let ((bits (lfun-bits thing)))
675                                   (declare (fixnum bits))
676                                   (if (logbitp $lfbits-trampoline-bit bits)
[3931]677                                     (let ((inner-fn (closure-function thing)))
[3437]678                                         (if (neq inner-fn thing)
679                                           (let ((inner-bits (lfun-bits inner-fn)))
680                                             (if (logbitp $lfbits-method-bit inner-bits)
681                                               'compiled-lexical-closure
682                                               (if (logbitp $lfbits-gfn-bit inner-bits)
683                                                 'standard-generic-function ; not precisely - see class-of
684                                                 (if (logbitp  $lfbits-cm-bit inner-bits)
685                                                   'combined-method
686                                                   'compiled-lexical-closure))))
[3931]687                                           'compiled-lexical-closure))
688                                     (if (logbitp  $lfbits-method-bit bits)
689                                       'method-function         
690                                       'compiled-function))))
[3437]691                                ((eq type 'lock)
692                                 (or (uvref thing ppc64::lock.kind-cell)
693                                     type))
694                                (t type))))
695                       (t 'immediate))))))))
696);#+ppc64-target
[1627]697
698
[10159]699#+x8632-target
700(progn
701(defparameter *nodeheader-types*
702  #(bogus                               ; 0
703    ratio                               ; 1
704    bogus                               ; 2
705    complex                             ; 3
706    catch-frame                         ; 4
707    function                            ; 5
[10247]708    basic-stream                        ; 6
[10159]709    symbol                              ; 7
710    lock                                ; 8
711    hash-table-vector                   ; 9
712    pool                                ; 10
713    population                          ; 11 (weak?)
714    package                             ; 12
715    slot-vector                         ; 13
716    standard-instance                   ; 14
717    structure                           ; 15
718    internal-structure                  ; 16
719    value-cell                          ; 17
720    xfunction                           ; 18
721    array-header                        ; 19
722    vector-header                       ; 20
723    simple-vector                       ; 21
724    bogus                               ; 22
725    bogus                               ; 23
726    bogus                               ; 24
727    bogus                               ; 25
728    bogus                               ; 26
729    bogus                               ; 27
730    bogus                               ; 28
731    bogus                               ; 29
732    bogus                               ; 30
733    bogus                               ; 31
734    ))
[3838]735
[10159]736
737(defparameter *immheader-types*
738  #(bignum                              ; 0
739    short-float                         ; 1
740    double-float                        ; 2
741    macptr                              ; 3
742    dead-macptr                         ; 4
743    code-vector                         ; 5
744    creole-object                       ; 6
745    xcode-vector                        ; 7
746    bogus                               ; 8
747    bogus                               ; 9
748    bogus                               ; 10
749    bogus                               ; 11
750    bogus                               ; 12
751    bogus                               ; 13
752    bogus                               ; 14
753    bogus                               ; 15
754    bogus                               ; 16
755    bogus                               ; 17
756    bogus                               ; 18
757    bogus                               ; 19
758    simple-short-float-vector           ; 20
759    simple-unsigned-long-vector         ; 21
760    simple-signed-long-vector           ; 22
761    simple-fixnum-vector                ; 23
762    simple-base-string                  ; 24
763    simple-unsigned-byte-vector         ; 25
764    simple-signed-byte-vector           ; 26
765    bogus                               ; 27
766    simple-unsigned-word-vector         ; 28
767    simple-signed-word-vector           ; 29
768    simple-double-float-vector          ; 30
769    simple-bit-vector                   ; 31
770    ))
771
772(defun %type-of (thing)
773  (let* ((typecode (typecode thing)))
774    (declare (fixnum typecode))
775    (if (= typecode x8632::tag-fixnum)
776      'fixnum
777      (if (= typecode x8632::tag-list)  ;a misnomer on x8632...
[11063]778        (if (= (fulltag thing) x8632::fulltag-cons)
[10159]779          (if thing 'cons 'null)
780          'tagged-return-address)
781        (if (= typecode x8632::tag-imm)
782          (if (base-char-p thing)
783            'base-char
784            'immediate)
785          (if (= typecode x8632::subtag-macptr)
786            (if (classp thing)
787              (class-name thing)
788              'macptr)
789            (let* ((tag-type (logand typecode x8632::fulltagmask))
790                   (tag-val (ash typecode (- x8632::ntagbits))))
791              (declare (fixnum tag-type tag-val))
792              (if (/= tag-type x8632::fulltag-nodeheader)
793                (%svref *immheader-types* tag-val)
794                (let ((type (%svref *nodeheader-types* tag-val)))
795                  (if (eq type 'function)
796                    (let ((bits (lfun-bits thing)))
797                      (declare (fixnum bits))
798                      (if (logbitp $lfbits-trampoline-bit bits)
799                        (let ((inner-fn (closure-function thing)))
800                          (if (neq inner-fn thing)
801                            (let ((inner-bits (lfun-bits inner-fn)))
802                              (if (logbitp $lfbits-method-bit inner-bits)
803                                'compiled-lexical-closure
804                                (if (logbitp $lfbits-gfn-bit inner-bits)
805                                  'standard-generic-function ; not precisely - see class-of
806                                  (if (logbitp  $lfbits-cm-bit inner-bits)
807                                    'combined-method
808                                    'compiled-lexical-closure))))
809                            'compiled-lexical-closure))
810                        (if (logbitp  $lfbits-method-bit bits)
811                          'method-function         
812                          'compiled-function)))
813                    (if (eq type 'lock)
814                      (or (uvref thing x8632::lock.kind-cell)
815                          type)
816                      type)))))))))))
817
818) ;x8632-target
819
[3567]820#+x8664-target
[3838]821(progn
822(defparameter *nodeheader-0-types*
[3885]823  #(bogus
[3838]824    symbol-vector
825    catch-frame
826    hash-vector
827    pool
828    population
829    package
830    slot-vector
[7624]831    basic-stream
[3885]832    function-vector                                        ;8
[5451]833    array-header
[3838]834    bogus
835    bogus
836    bogus
837    bogus
838    bogus
839    ))
[3437]840
[3838]841(defparameter *nodeheader-1-types*
[3885]842  #(bogus
843    ratio
[3838]844    complex
[3931]845    structure
[10351]846    internal-structure
[3838]847    value-cell
848    xfunction
[3885]849    lock
850    instance
851    bogus
852    vector-header
[3838]853    simple-vector
854    bogus
855    bogus
856    bogus
857    bogus
858    ))
[3437]859
[3838]860(defparameter *immheader-0-types*
861  #(bogus
862    bogus
863    bogus
864    bogus
865    bogus
866    bogus
867    bogus
868    bogus
869    bogus
870    bogus
871    simple-signed-word-vector
872    simple-unsigned-word-vector
[5389]873    bogus
[3838]874    simple-signed-byte-vector
875    simple-unsigned-byte-vector
876    bit-vector))
[3567]877
[3838]878(defparameter *immheader-1-types*
[4098]879  #(bogus
880    bignum
[3838]881    double-float
882    xcode-vector
883    bogus
884    bogus
885    bogus
886    bogus
887    bogus
888    bogus
889    bogus
890    bogus
[5389]891    simple-base-string
[3838]892    simple-signed-long-vector
893    simple-unsigned-long-vector
894    single-float-vector))
895
896(defparameter *immheader-2-types*
[4048]897  #(bogus
898    macptr
[3838]899    dead-macptr
900    bogus
901    bogus
902    bogus
903    bogus
904    bogus
905    bogus
906    bogus
907    bogus
908    bogus
[4645]909    simple-fixnum-vector
[3838]910    simple-signed-doubleword-vector
911    simple-unsigned-doubleword-vector
912    double-float-vector))
913
914
[3931]915(defparameter *x8664-%type-of-functions* nil)
916
917(let* ((fixnum (lambda (x) (declare (ignore x)) 'fixnum))
918       (tra (lambda (x) (declare (ignore x)) 'tagged-return-address))
919       (bogus (lambda (x) (declare (ignore x)) 'bogus)))
920  (setq *x8664-%type-of-functions*
921        (vector
922         fixnum                         ;0
923         (lambda (x) (declare (ignore x)) 'short-float) ;1
924         (lambda (x) (if (characterp x) 'character 'immediate)) ;2
925         (lambda (x) (declare (ignore x)) 'cons) ;3
926         tra                            ;4
927         bogus                          ;5
928         bogus                          ;6
929         bogus                          ;7
930         fixnum                         ;8
931         bogus                          ;9
932         bogus                          ;10
933         (lambda (x) (declare (ignore x)) 'null) ;11
934         tra                            ;12
935         (lambda (x) (let* ((typecode (typecode x)) 
936                            (low4 (logand typecode x8664::fulltagmask))
937                            (high4 (ash typecode (- x8664::ntagbits))))
938                       (declare (type (unsigned-byte 8) typecode)
939                                (type (unsigned-byte 4) low4 high4))
940                       (let* ((name
941                               (cond ((= low4 x8664::fulltag-immheader-0)
942                                      (%svref *immheader-0-types* high4))
943                                     ((= low4 x8664::fulltag-immheader-1)
944                                      (%svref *immheader-1-types* high4))
945                                     ((= low4 x8664::fulltag-immheader-2)
946                                      (%svref *immheader-2-types* high4))
947                                     ((= low4 x8664::fulltag-nodeheader-0)
948                                      (%svref *nodeheader-0-types* high4))
949                                     ((= low4 x8664::fulltag-nodeheader-1)
950                                      (%svref *nodeheader-1-types* high4))
951                                     (t 'bogus))))
952                         (or (and (eq name 'lock)
953                                  (uvref x x8664::lock.kind-cell))
954                             name)))) ;13
955         (lambda (x) (declare (ignore x)) 'symbol) ;14
956         (lambda (thing)
957           (let ((bits (lfun-bits thing)))
958             (declare (fixnum bits))
959             (if (logbitp $lfbits-trampoline-bit bits)
960               (let ((inner-fn (closure-function thing)))
961                 (if (neq inner-fn thing)
962                   (let ((inner-bits (lfun-bits inner-fn)))
963                     (if (logbitp $lfbits-method-bit inner-bits)
964                       'compiled-lexical-closure
965                       (if (logbitp $lfbits-gfn-bit inner-bits)
966                         'standard-generic-function ; not precisely - see class-of
967                         (if (logbitp  $lfbits-cm-bit inner-bits)
968                           'combined-method
969                           'compiled-lexical-closure))))
970                   'compiled-lexical-closure))
971               (if (logbitp  $lfbits-method-bit bits)
972                 'method-function         
973                 'compiled-function))))))) ;15
974                                     
975       
976
977
[3838]978 
979(defun %type-of (thing)
[3931]980  (let* ((f (fulltag thing)))
981    (funcall (%svref *x8664-%type-of-functions* f) thing)))
982
[3885]983       
[3838]984
985);#+x8664-target
986     
987
[1418]988;;; real machine specific huh
[929]989(defun consp (x)
990  "Return true if OBJECT is a CONS, and NIL otherwise."
991  (consp x))
[6]992
993(defun characterp (arg)
[929]994  "Return true if OBJECT is a CHARACTER, and NIL otherwise."
[6]995  (characterp arg))
996
997(defun base-char-p (c)
998  (base-char-p c))
999
1000
1001
1002
1003(defun structurep (form)
1004  "True if the given object is a named structure, Nil otherwise."
[1326]1005  (= (the fixnum (typecode form)) target::subtag-struct))
[6]1006
1007(defun istructp (form)
[1326]1008  (= (the fixnum (typecode form)) target::subtag-istruct))
[6]1009
[10406]1010
1011;;; Not to be conused with STRUCTURE-TYPE-P, defined in ccl:lib;pprint.lisp.
1012;;; (If you've ever been "conused", I'm sure you know just how painful
1013;;; that can be.)
[6]1014(defun structure-typep (thing type)
[1326]1015  (if (= (the fixnum (typecode thing)) target::subtag-struct)
[10458]1016    (let* ((types (%svref thing 0)))
1017      (if (typep type 'symbol)
1018        (dolist (x types)
1019          (when (eq (class-cell-name x) type)
1020            (return t)))
1021        (dolist (x types)
1022          (when (eq x type)
1023            (return t)))))))
[10406]1024
[10458]1025
1026
[6]1027(defun istruct-typep (thing type)
[1326]1028  (if (= (the fixnum (typecode thing)) target::subtag-istruct)
[10321]1029    (eq (istruct-cell-name (%svref thing 0)) type)))
[6]1030
[10282]1031(defun istruct-type-name (thing)
1032  (if (= (the fixnum (typecode thing)) target::subtag-istruct)
1033    (istruct-cell-name (%svref thing 0))))
1034
1035
1036;;; This is actually set to an alist in the xloader.
1037(defparameter *istruct-cells* nil)
1038
1039;;; This should only ever push anything on the list in the cold
1040;;; load (e.g., when running single-threaded.)
1041(defun register-istruct-cell (name)
1042  (or (assq name *istruct-cells*)
1043      (let* ((pair (cons name nil)))
1044        (push pair *istruct-cells*)
1045        pair)))
1046
1047(defun set-istruct-cell-info (cell info)
1048  (etypecase cell
1049    (cons (%rplacd cell info)))
1050  info)
1051
1052
[6]1053(defun symbolp (thing)
[929]1054  "Return true if OBJECT is a SYMBOL, and NIL otherwise."
[13789]1055  #+(or ppc32-target x8632-target arm-target)
[6]1056  (if thing
[10159]1057    (= (the fixnum (typecode thing)) target::subtag-symbol)
[1418]1058    t)
1059  #+ppc64-target
[3437]1060  (= (the fixnum (typecode thing)) ppc64::subtag-symbol)
1061  #+x8664-target
1062  (if thing
1063    (= (the fixnum (lisptag thing)) x8664::tag-symbol)
1064    t)
1065  )
[1418]1066     
[6]1067(defun packagep (thing)
[1326]1068  (= (the fixnum (typecode thing)) target::subtag-package))
[6]1069
[1418]1070;;; 1 if by land, 2 if by sea.
[6]1071(defun sequence-type (x)
[1326]1072  (unless (>= (the fixnum (typecode x)) target::min-vector-subtag)
[6]1073    (or (listp x)
1074        (report-bad-arg x 'sequence))))
1075
1076(defun uvectorp (x)
[1326]1077  (= (the fixnum (fulltag x)) target::fulltag-misc))
[964]1078
1079(setf (type-predicate 'uvector) 'uvectorp)
[9310]1080
1081(defun listp (x)
1082  (listp x))
[10406]1083
1084(defparameter *type-cells* nil)
1085
1086
1087
1088(defparameter *type-cells-lock* nil)
1089
1090
1091;;; The weird handling to the special variables here has to do with
1092;;; xload issues.
1093(defun register-type-cell (specifier)
1094  (with-lock-grabbed ((or *type-cells-lock*
1095                         (setq *type-cells-lock* (make-lock))))
1096    (unless *type-cells*
1097      (setq *type-cells* (make-hash-table :test 'equal)))
1098    (or (values (gethash specifier *type-cells*))
1099        (setf (gethash specifier *type-cells*)
1100              (make-type-cell specifier)))))
1101
1102
1103(defvar %find-classes% nil)
1104
1105(setq %find-classes% (make-hash-table :test 'eq))
1106
1107
1108(defun find-class-cell (name create?)
1109  (unless %find-classes%
1110    (dbg name))
1111  (let ((cell (gethash name %find-classes%)))
1112    (or cell
1113        (and create?
1114             (setf (gethash name %find-classes%) (make-class-cell name))))))
1115
Note: See TracBrowser for help on using the repository browser.