Changeset 14756

Timestamp:

Apr 29, 2011, 2:49:16 PM (14 years ago)

Author:

Gary Byers

Message:

sysutils.lisp: REQUIRE-STRUCTURE-TYPE; basically inlines a
STRUCTURE-TYPEP test and allows the error signalling to happen
out-of-line if the test fails.

optimizers.lisp: if REQUIRE-STRUCTURE-TYPE is defined, transform
(REQUIRE-TYPE thing 'structure-class-name) into a call to
REQUIRE-STRUCTURE-TYPE.

Location:

trunk/source

Files:

• compiler/optimizers.lisp (modified) (2 diffs)
• level-1/sysutils.lisp (modified) (2 diffs)

trunk/source/compiler/optimizers.lisp

@@ -941 +941 @@
   (if first-p
     (if rest call first)))
+
+
+
 
 ;;; This isn't quite right... The idea is that (car (require-type foo
@@ -1003 +1006 @@
                            ((and (symbolp type)(find-class type nil env))
                             `(%require-type-class-cell ,arg (load-time-value (find-class-cell ',type t))))
+                           ((and (symbolp type)
+                                 #-bootstrapped-this (fboundp 'require-structure-type)
+                                 (structure-class-p type env))
+                            `(require-structure-type ,arg (load-time-value (find-class-cell ',type t))))
                            (t (let* ((val (gensym)))
                                 `(the ,type

trunk/source/level-1/sysutils.lisp

@@ -310 +310 @@
       (%kernel-restart $xwrongtype arg type))))
 
+
+
 ;;; Might want to use an inverted mapping instead of (satisfies ccl::obscurely-named)
 (defun %require-type (arg predsym)
@@ -321 +323 @@
     (%kernel-restart $xwrongtype arg (car type-cell))))
 
-
+(defun require-structure-type (arg token)
+  (or(and (= (the fixnum (typecode arg)) target::subtag-struct)
+           (dolist (x (%svref arg 0))
+             (declare (optimize (speed 3) (safety 0)))
+             (when (eq x token) (return arg))))
+    (%kernel-restart $xwrongtype arg (if (typep token 'class-cell) (class-cell-name token) token))))
 
 ;;; In lieu of an inverted mapping, at least try to find cases involving