/[cmucl]/src/code/pred.lisp
ViewVC logotype

Contents of /src/code/pred.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.61 - (show annotations)
Mon Nov 2 02:51:57 2009 UTC (4 years, 5 months ago) by rtoy
Branch: MAIN
Changes since 1.60: +34 -1 lines
This large checkin brings the amd64 port up-to-date with the current
sources.  No real attempt has been made to make it work, but the
cross-compile does create a kernel.core, and the C code compiles (on
openSuSE 10.3).  The resulting kernel.core does not yet work.

Use cross-x86-amd64.lisp as the cross-compile script.  This is
intended to be cross-compiled using the 20a release for Linux, and
only supports x87.  The sse2 support has not be ported yet.

tools/cross-scripts/cross-x86-amd64.lisp:
o Update cross-compile with some missing constants, and frob new
  symbols.

tools/clean-target.sh:
o Remove amd64f files too.

code/pred.lisp:
o Define predicates for double-doubles for bootstrapping to work
  around recursive known function problems with these predicates.

code/sap.lisp:
o Define int-sap with (unsigned-byte 64) type declaration.  (May not
  be needed?)

code/unix-glibc2.lisp:
o Build fails defining map_failed to (int-sap -1).  Just hard-wire to
  0 for now so we can build.

compiler/float-tran.lisp:
o Add missing conditional for %complex-double-double-float.

compiler/amd64/float.lisp:
o Merge double-double support for amd64.  Not really tested yet.

compiler/amd64/parms.lisp:
o Update to match x86 build.  In particular, get the space address
  correct and update the static symbols.

compiler/amd64/type-vops.lisp:
o DYLAN-FUNCTION-HEADER-TYPE no longer exists.

compiler/amd64/vm.lisp:
o Add double-double storage classes and register definitions.

lisp/Config.amd64:
o Bring in line with Config.x86 and friends.

lisp/Linux-os.c:
o Bring amd64 code up-to-date with x86/linux code.

lisp/Linux-os.h
o Need to include sys/ucontext.h to get ucontext defined.  (Why?)
o Also define __USE_GNU so we get the register offsets in the ucontext
  defined.  (Why?)

lisp/amd64-arch.c:
o Change struct sigcontext to os_context_t.
o Use SC_PC instead of context->sc_pc.
o Merge some changes in from x86 version, like SC_EFLAGS.  May need
  more work.

lisp/amd64-assem.s:
o Use rbx instead of ebx for jmp.

lisp/amd64-lispregs.h:
o Define SC_REG, SC_PC, SC_SP using the new x86 style.

lisp/backtrace.c:
o Remove inline assembly for now until I figure out what the amd64
  version should be.

lisp/gencgc.c:
o Conditionalize out weak hash table support for now.

lisp/gencgc.h:
o Set PAGE_SIZE for amd64.  (Is 4096 right?)

lisp/globals.h:
o Export current_dynamic_space_free_pointer and
  current_auto_gc_trigger like for x86.
1 ;;; -*- Mode: Lisp; Package: LISP; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/pred.lisp,v 1.61 2009/11/02 02:51:57 rtoy Exp $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Predicate functions for CMU Common Lisp.
13 ;;;
14 ;;; Written by William Lott.
15 ;;;
16
17 (in-package "KERNEL")
18 (export '(%instancep instance fixnump bignump bitp ratiop weak-pointer-p
19 %typep class-cell-typep))
20
21 #+double-double
22 (export '(double-double-float-p))
23
24 (in-package "SYSTEM")
25 (export '(system-area-pointer system-area-pointer-p))
26
27 (in-package "LISP")
28
29 (export '(typep null symbolp atom consp listp numberp integerp rationalp
30 floatp complexp characterp stringp bit-vector-p vectorp
31 simple-vector-p simple-string-p simple-bit-vector-p arrayp
32 functionp compiled-function-p eq eql equal equalp not
33 type-of upgraded-array-element-type realp
34 ;; Names of types...
35 array atom bignum bit bit-vector character
36 compiled-function complex cons double-float
37 fixnum float function integer keyword list long-float nil
38 null number ratio rational real sequence short-float signed-byte
39 simple-array simple-bit-vector simple-string simple-vector
40 single-float standard-char base-char string symbol t
41 unsigned-byte vector satisfies))
42
43
44
45 ;;;; Primitive predicates. These must be supported by the compiler.
46
47 (eval-when (compile eval)
48 (defparameter primitive-predicates
49 '(array-header-p
50 arrayp
51 atom
52 base-char-p
53 bignump
54 bit-vector-p
55 characterp
56 code-component-p
57 consp
58 compiled-function-p
59 complexp
60 complex-double-float-p
61 complex-float-p
62 #+long-float complex-long-float-p
63 #+double-double complex-double-double-float-p
64 complex-rational-p
65 complex-single-float-p
66 #+double-double double-double-float-p
67 double-float-p
68 fdefn-p
69 fixnump
70 floatp
71 functionp
72 integerp
73 listp
74 long-float-p
75 lra-p
76 not
77 null
78 numberp
79 rationalp
80 ratiop
81 realp
82 scavenger-hook-p
83 short-float-p
84 simple-array-p
85 simple-bit-vector-p
86 simple-string-p
87 simple-vector-p
88 single-float-p
89 stringp
90 %instancep
91 symbolp
92 system-area-pointer-p
93 weak-pointer-p
94 vectorp
95 unsigned-byte-32-p
96 signed-byte-32-p
97 simple-array-unsigned-byte-2-p
98 simple-array-unsigned-byte-4-p
99 simple-array-unsigned-byte-8-p
100 simple-array-unsigned-byte-16-p
101 simple-array-unsigned-byte-32-p
102 simple-array-signed-byte-8-p
103 simple-array-signed-byte-16-p
104 simple-array-signed-byte-30-p
105 simple-array-signed-byte-32-p
106 simple-array-single-float-p
107 simple-array-double-float-p
108 #+long-float simple-array-long-float-p
109 #+double-double simple-array-double-double-float-p
110 simple-array-complex-single-float-p
111 simple-array-complex-double-float-p
112 #+long-float simple-array-complex-long-float-p
113 #+double-double simple-array-complex-double-double-float-p
114 )))
115
116 (macrolet
117 ((frob ()
118 `(progn
119 ,@(mapcar #'(lambda (pred)
120 `(defun ,pred (object)
121 ,(format nil
122 "Return T if OBJECT is a~:[~;n~] ~(~A~) ~
123 and NIL otherwise."
124 (find (schar (string pred) 0) "AEIOUaeiou")
125 (string pred))
126 (,pred object)))
127 primitive-predicates))))
128 (frob))
129
130 ;;; FIXME: The next four functions are for bootstrapping double-double
131 ;;; for AMD64. This works around the recursive known function problem
132 ;;; when compiling the predicate functions for double-double. This
133 ;;; should be eventually removed when double-double float support for
134 ;;; the compiler is working.
135 (defun double-double-float-p (x)
136 (let* ((addr (kernel:get-lisp-obj-address x))
137 (ptr (logandc2 addr #x7)))
138 (when (= 1 (logand addr 1))
139 (= 26 (ldb (byte 8 0)
140 (sys:sap-ref-32 (sys:int-sap ptr) 0))))))
141
142 (defun complex-double-double-float-p (x)
143 (let* ((addr (kernel:get-lisp-obj-address x))
144 (ptr (logandc2 addr #x7)))
145 (when (= 1 (logand addr 1))
146 (= 42 (ldb (byte 8 0)
147 (sys:sap-ref-32 (sys:int-sap ptr) 0))))))
148
149 (defun simple-array-double-double-float-p (x)
150 (let* ((addr (kernel:get-lisp-obj-address x))
151 (ptr (logandc2 addr #x7)))
152 (when (= 1 (logand addr 1))
153 (= 106 (ldb (byte 8 0)
154 (sys:sap-ref-32 (sys:int-sap ptr) 0))))))
155
156 (defun simple-array-complex-double-double-float-p (x)
157 (let* ((addr (kernel:get-lisp-obj-address x))
158 (ptr (logandc2 addr #x7)))
159 (when (= 1 (logand addr 1))
160 (= 118 (ldb (byte 8 0)
161 (sys:sap-ref-32 (sys:int-sap ptr) 0))))))
162
163
164 ;;;; TYPE-OF -- public.
165 ;;;
166 ;;; Return the specifier for the type of object. This is not simply
167 ;;; (type-specifier (ctype-of object)) because ctype-of has different goals
168 ;;; than type-of. In particular, speed is more important than precision, and
169 ;;; it is not permitted to return member types.
170 ;;;
171 (defun type-of (object)
172 "Return the type of OBJECT."
173 (typecase object
174 ((or array complex)
175 (type-specifier (ctype-of object)))
176 (integer
177 `(integer ,object ,object))
178 ((member t)
179 'boolean)
180 (keyword
181 'keyword)
182 (standard-char
183 'standard-char)
184 (t
185 (let* ((class (layout-class (layout-of object)))
186 (name (%class-name class)))
187 (if (%instancep object)
188 (if (eq name 'alien-internals:alien-value)
189 `(alien:alien ,(alien-internals:unparse-alien-type
190 (alien-internals:alien-value-type object)))
191 (let ((proper-name (class-proper-name class)))
192 (if (kernel::class-p proper-name)
193 (%class-pcl-class proper-name)
194 proper-name)))
195 name)))))
196
197
198 ;;;; UPGRADED-ARRAY-ELEMENT-TYPE -- public
199 ;;;
200 (defun upgraded-array-element-type (spec &optional environment)
201 "Return the element type that will actually be used to implement an array
202 with the specifier :ELEMENT-TYPE Spec."
203 ;; Type expansion (TYPE-EXPAND) currently doesn't handle environments.
204 (declare (ignore environment))
205 (type-specifier
206 (array-type-specialized-element-type
207 (specifier-type `(array ,spec)))))
208
209 ;;;; SUBTYPEP -- public.
210 ;;;
211 ;;; Just parse the type specifiers and call csubtype.
212 ;;;
213 (defun subtypep (type1 type2 &optional environment)
214 "Return two values indicating the relationship between type1 and type2:
215 T and T: type1 definitely is a subtype of type2.
216 NIL and T: type1 definitely is not a subtype of type2.
217 NIL and NIL: who knows?"
218 (declare (ignore environment))
219 (csubtypep (specifier-type type1) (specifier-type type2)))
220
221
222 ;;;; TYPEP:
223
224 (declaim (start-block typep %typep class-cell-typep))
225
226 ;;; TYPEP -- public.
227 ;;;
228 ;;; Just call %typep
229 ;;;
230 (defun typep (object type &optional environment)
231 "Return T iff OBJECT is of type TYPE."
232 (declare (ignore environment))
233 (%typep object type))
234
235
236 ;;; %TYPEP -- internal.
237 ;;;
238 ;;; The actual typep engine. The compiler only generates calls to this
239 ;;; function when it can't figure out anything more intelligent to do.
240 ;;;
241 (defun %typep (object specifier)
242 (%%typep object
243 (if (ctype-p specifier)
244 specifier
245 (specifier-type specifier))))
246 ;;;
247 (defun %%typep (object type)
248 (declare (type ctype type))
249 (etypecase type
250 (named-type
251 (ecase (named-type-name type)
252 ((* t) t)
253 ((nil) nil)))
254 (numeric-type
255 (and (numberp object)
256 (let ((num (if (complexp object) (realpart object) object)))
257 (ecase (numeric-type-class type)
258 (integer (integerp num))
259 (rational (rationalp num))
260 (float
261 (ecase (numeric-type-format type)
262 (short-float (typep num 'short-float))
263 (single-float (typep num 'single-float))
264 (double-float (typep num 'double-float))
265 (long-float (typep num 'long-float))
266 (double-double-float (typep num 'double-double-float))
267 ((nil) (floatp num))))
268 ((nil) t)))
269 (flet ((bound-test (val)
270 (let ((low (numeric-type-low type))
271 (high (numeric-type-high type)))
272 (and (cond ((null low) t)
273 ((listp low) (> val (car low)))
274 (t (>= val low)))
275 (cond ((null high) t)
276 ((listp high) (< val (car high)))
277 (t (<= val high)))))))
278 (ecase (numeric-type-complexp type)
279 ((nil) t)
280 (:complex
281 (and (complexp object)
282 (bound-test (realpart object))
283 (bound-test (imagpart object))))
284 (:real
285 (and (not (complexp object))
286 (bound-test object)))))))
287 (array-type
288 (and (arrayp object)
289 (ecase (array-type-complexp type)
290 ((t) (not (typep object 'simple-array)))
291 ((nil) (typep object 'simple-array))
292 ((* :maybe) t))
293 (or (eq (array-type-dimensions type) '*)
294 (do ((want (array-type-dimensions type) (cdr want))
295 (got (array-dimensions object) (cdr got)))
296 ((and (null want) (null got)) t)
297 (unless (and want got
298 (or (eq (car want) '*)
299 (= (car want) (car got))))
300 (return nil))))
301 (if (unknown-type-p (array-type-element-type type))
302 ;; better to fail this way than to get bogosities like
303 ;; (TYPEP (MAKE-ARRAY 11) '(ARRAY SOME-UNDEFINED-TYPE)) => T
304 (error "~@<unknown element type in array type: ~2I~_~S~:>"
305 (type-specifier type))
306 t)
307 (or (eq (array-type-element-type type) *wild-type*)
308 (values (type= (array-type-specialized-element-type type)
309 (specifier-type (array-element-type
310 object)))))))
311 (member-type
312 (if (member object (member-type-members type)) t))
313 (kernel::class
314 (class-typep (layout-of object) type object))
315 (union-type
316 (some (lambda (type) (%%typep object type))
317 (union-type-types type)))
318 (intersection-type
319 (every (lambda (type) (%%typep object type))
320 (intersection-type-types type)))
321 (cons-type
322 (and (consp object)
323 (%%typep (car object) (cons-type-car-type type))
324 (%%typep (cdr object) (cons-type-cdr-type type))))
325 (unknown-type
326 ;; Parse it again to make sure it's really undefined.
327 (let ((reparse (specifier-type (unknown-type-specifier type))))
328 (if (typep reparse 'unknown-type)
329 (error "Unknown type specifier: ~S"
330 (unknown-type-specifier reparse))
331 (%%typep object reparse))))
332 (negation-type
333 (not (%%typep object (negation-type-type type))))
334 (hairy-type
335 ;; Now the tricky stuff.
336 (let* ((hairy-spec (hairy-type-specifier type))
337 (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
338 (ecase symbol
339 (and
340 (every (lambda (spec) (%%typep object (specifier-type spec)))
341 (rest hairy-spec)))
342 ;; Note: it should be safe to skip OR here, because union
343 ;; types can always be represented as UNION-TYPE in general
344 ;; or other CTYPEs in special cases; we never need to use
345 ;; HAIRY-TYPE for them.
346 (not
347 (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
348 (error "Invalid type specifier: ~S" hairy-spec))
349 (not (%%typep object (specifier-type (cadr hairy-spec)))))
350 (satisfies
351 (unless (and (listp hairy-spec) (= (length hairy-spec) 2))
352 (error "Invalid type specifier: ~S" hairy-spec))
353 (let ((fn (cadr hairy-spec)))
354 (if (funcall (typecase fn
355 (function fn)
356 (symbol (symbol-function fn))
357 (t
358 (coerce fn 'function)))
359 object)
360 t
361 nil))))))
362 (alien-type-type
363 (alien-internals:alien-typep object (alien-type-type-alien-type type)))
364 (function-type
365 (error "Function types are not a legal argument to TYPEP:~% ~S"
366 (type-specifier type)))))
367
368
369 ;;; CLASS-CELL-TYPEP -- Interface
370 ;;;
371 ;;; Do type test from a class cell, allowing forward reference and
372 ;;; redefinition.
373 ;;;
374 (defun class-cell-typep (obj-layout cell object)
375 (let ((class (class-cell-class cell)))
376 (unless class
377 (error "Class has not yet been defined: ~S" (class-cell-name cell)))
378 (class-typep obj-layout class object)))
379
380
381 ;;; CLASS-TYPEP -- Internal
382 ;;;
383 ;;; Test whether Obj-Layout is from an instance of Class.
384 ;;;
385 (defun class-typep (obj-layout class object)
386 (declare (optimize speed))
387 (when (layout-invalid obj-layout)
388 (if (and (typep (kernel::class-of object) 'kernel::standard-class) object)
389 (setq obj-layout (pcl::check-wrapper-validity object))
390 (error "TYPEP on obsolete object (was class ~S)."
391 (class-proper-name (layout-class obj-layout)))))
392 (let ((layout (%class-layout class))
393 (obj-inherits (layout-inherits obj-layout)))
394 (when (layout-invalid layout)
395 (error "Class is currently invalid: ~S" class))
396 (or (eq obj-layout layout)
397 (dotimes (i (length obj-inherits) nil)
398 (when (eq (svref obj-inherits i) layout)
399 (return t))))))
400
401 (declaim (end-block))
402
403
404 ;;;; Equality predicates.
405
406 ;;; EQ -- public.
407 ;;;
408 ;;; Real simple, 'cause the compiler takes care of it.
409 ;;;
410
411 (defun eq (obj1 obj2)
412 "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
413 (eq obj1 obj2))
414
415
416 ;;; EQUAL -- public.
417 ;;;
418 (defun equal (x y)
419 "Returns T if X and Y are EQL or if they are structured components
420 whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
421 are the same length and have indentical components. Other arrays must be
422 EQ to be EQUAL."
423 (cond ((eql x y) t)
424 ((consp x)
425 (and (consp y)
426 (equal (car x) (car y))
427 (equal (cdr x) (cdr y))))
428 ((stringp x)
429 (and (stringp y) (string= x y)))
430 ((pathnamep x)
431 (and (pathnamep y) (pathname= x y)))
432 ((bit-vector-p x)
433 (and (bit-vector-p y)
434 (= (the fixnum (length x))
435 (the fixnum (length y)))
436 (do ((i 0 (1+ i))
437 (length (length x)))
438 ((= i length) t)
439 (declare (fixnum i))
440 (or (= (the fixnum (bit x i))
441 (the fixnum (bit y i)))
442 (return nil)))))
443 (t nil)))
444
445 ;;; EQUALP -- public.
446 ;;;
447 (defun equalp (x y)
448 "Just like EQUAL, but more liberal in several respects.
449 Numbers may be of different types, as long as the values are identical
450 after coercion. Characters may differ in alphabetic case. Vectors and
451 arrays must have identical dimensions and EQUALP elements, but may differ
452 in their type restriction."
453 (cond ((eq x y) t)
454 ((characterp x) (and (characterp y) (char-equal x y)))
455 ((numberp x) (and (numberp y) (= x y)))
456 ((consp x)
457 (and (consp y)
458 (equalp (car x) (car y))
459 (equalp (cdr x) (cdr y))))
460 ((pathnamep x)
461 (and (pathnamep y) (pathname= x y)))
462 ((hash-table-p x)
463 (and (hash-table-p y)
464 (eql (hash-table-count x) (hash-table-count y))
465 (eql (hash-table-test x) (hash-table-test y))
466 (with-hash-table-iterator (next x)
467 (loop
468 (multiple-value-bind (more x-key x-value)
469 (next)
470 (cond (more
471 (multiple-value-bind (y-value foundp)
472 (gethash x-key y)
473 (unless (and foundp (equalp x-value y-value))
474 (return nil))))
475 (t
476 (return t))))))))
477 ((%instancep x)
478 (let* ((layout-x (%instance-layout x))
479 (len (layout-length layout-x)))
480 (and (%instancep y)
481 (eq layout-x (%instance-layout y))
482 (structure-class-p (layout-class layout-x))
483 (do ((i 1 (1+ i)))
484 ((= i len) t)
485 (declare (fixnum i))
486 (let ((x-el (%instance-ref x i))
487 (y-el (%instance-ref y i)))
488 (unless (or (eq x-el y-el)
489 (equalp x-el y-el))
490 (return nil)))))))
491 ((vectorp x)
492 (let ((length (length x)))
493 (and (vectorp y)
494 (= length (length y))
495 (dotimes (i length t)
496 (let ((x-el (aref x i))
497 (y-el (aref y i)))
498 (unless (or (eq x-el y-el)
499 (equalp x-el y-el))
500 (return nil)))))))
501 ((arrayp x)
502 (and (arrayp y)
503 (= (array-rank x) (array-rank y))
504 (dotimes (axis (array-rank x) t)
505 (unless (= (array-dimension x axis)
506 (array-dimension y axis))
507 (return nil)))
508 (dotimes (index (array-total-size x) t)
509 (let ((x-el (row-major-aref x index))
510 (y-el (row-major-aref y index)))
511 (unless (or (eq x-el y-el)
512 (equalp x-el y-el))
513 (return nil))))))
514 (t nil)))

  ViewVC Help
Powered by ViewVC 1.1.5