source: trunk/source/level-0/l0-pred.lisp @ 15093

Last change on this file since 15093 was 15093, checked in by gb, 8 years ago

New Linux ARM binaries.

The image and FASL versions changed on the ARM, but (if I did it right)
not on other platforms.

(The image and FASL versions are now architecture-specific. This may
make it somewhat easier and less disruptive to change them, since the
motivation for such a change is often also architecture-specific.)
The FASL and current image version are defined (in the "TARGET" package)
in the architecture-specific *-arch.lisp files; the min, max, and current
image versions are defined in the *constants*.h file for the architecture.

Most of the changes are ARM-specific.

Each TCR now contains a 256-word table at byte offset 256. (We've
been using about 168 bytes in the TCR, so there are still 88 bytes/22
words left for expansion.) The table is initialized at TCR-creation
time to contain the absolute addresses of the subprims (there are
currently around 130 defined); we try otherwise not to reference
subprims by absolute address. Jumping to a subprim is:

(ldr pc (:@ rcontext (:$ offset-of-subprim-in-tcr-table)))

and calling one involves loading its address from that table into a
register and doing (blx reg). We canonically use LR as the register,
since it's going to be clobbered by the blx anyway and there doesn't
seem to be a performance hazard there. The old scheme (which involved
using BA and BLA pseudoinstructions to jump to/call a hidden jump table
at the end of the function) is no longer supported.

ARM Subprims no longer need to be aligned (on anything more than an
instruction boundary.) Some remnants of the consequences of an old
scheme (where subprims had to "fit" in small regions and sometimes
had to jump out of line if they would overflow that region's bounds)
still remain, but we can repair that (and it'll be a bit more straightforward
to add new ARM subprims.) We no longer care (much) about where subprims
are mapped in memory, and don't have to bias suprimitive addresses by
a platform-specific constant (and have to figure out whether or not we've
already done so) on (e.g.) Android.

Rather than setting the first element (fn.entrypoint) of a
newly-created function to the (absolute) address of a subprim that updates
that entrypoint on the first call, we use a little LAP function to correct
the address before the function can be called.

Non-function objects that can be stored in symbols' function cells
(the UNDEFINED-FUNCTION object, the things that encapsulate
special-operator names and global macro-functions) need to be
structured like FUNCTIONS: the need to have a word-aligned entrypoint
in element 0 that tracks the CODE-VECTOR object in element 1. We
don't want these things to be of type FUNCTION, but do want the GC to
adjust the entrypoint if the codevector moves. We've been essentially
out of GVECTOR subtags on 32-bit platforms, largely because of the
constraints that vector/array subtags must be greater than other
subtags and numeric types be less. The first constraint is probably
reasonable, but the second isn't: other typecodes (tag-list, etc) may
be less than the maximum numeric typecode, so tests like NUMBERP can't
reliably involve a simple comparison. (As long as a mask of all
numeric typecodes will fit in a machine word/FIXNUM, a simple LOGBITP
test can be used instead.) Removed all portable and ARM-specific code
that made assumptions about numeric typecode ordering, made a few more
gvector typecodes available, and used one of them to define a new
"pseudofunction" type. Made the GC update the entrypoints of
pseudofunctions and used them for the undefined-function object and
for the function cells of macros/special-operators.

Since we don't need the subprim jump table at the end of each function
anymore, we can more easily revive the idea of embedded pc-relative
constant data ("constant pools") and initialize FPRs from constant
data, avoiding most remaining traffic between FPRs and GPRs.

I've had a fairly-reproducible cache-coherency problem: on the first
GC in the cold load, the thread misbehaves mysteriously when it
resumes. The GC tries to synchronize the I and D caches on the entire
range of addresses that may contain newly-moved code-vectors. I'm not
at all sure why, but walking that range and flushing the cache for
each code-vector individually seems to avoid the problem (and may actually
be faster.)

Fix ticket:894

Fixed a few typos in error messages/comments/etc.

I -think- that the non-ARM-specific changes (how FASL/image versions are
defined) should bootstrap cleanly, but won't know for sure until this is
committed. (I imagine that the buildbot will complain if not.)

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