[Openmcl-cvs-notifications] r14756 - in /trunk/source: compiler/optimizers.lisp level-1/sysutils.lisp

[gb at clozure.com]

Author: gb
Date: Fri Apr 29 16:49:16 2011
New Revision: 14756

Log:
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.

Modified:
    trunk/source/compiler/optimizers.lisp
    trunk/source/level-1/sysutils.lisp

Modified: trunk/source/compiler/optimizers.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/optimizers.lisp (original)
+++ trunk/source/compiler/optimizers.lisp Fri Apr 29 16:49:16 2011
@@ -940,6 +940,9 @@
 (define-compiler-macro progn (&whole call &optional (first nil first-p) &r=
est rest)
   (if first-p
     (if rest call first)))
+
+
+
 =

 ;;; This isn't quite right... The idea is that (car (require-type foo
 ;;; 'list)) ;can become just (<typechecking-car> foo) [regardless of
@@ -1002,6 +1005,10 @@
                            #+nil
                            ((and (symbolp type)(find-class type nil env))
                             `(%require-type-class-cell ,arg (load-time-val=
ue (find-class-cell ',type t))))
+                           ((and (symbolp type)
+                                 #-bootstrapped-this (fboundp 'require-str=
ucture-type)
+                                 (structure-class-p type env))
+                            `(require-structure-type ,arg (load-time-value=
 (find-class-cell ',type t))))
                            (t (let* ((val (gensym)))
                                 `(the ,type
                                    (let* ((,val ,arg))

Modified: trunk/source/level-1/sysutils.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/sysutils.lisp (original)
+++ trunk/source/level-1/sysutils.lisp Fri Apr 29 16:49:16 2011
@@ -309,6 +309,8 @@
       arg
       (%kernel-restart $xwrongtype arg type))))
 =

+
+
 ;;; Might want to use an inverted mapping instead of (satisfies ccl::obscu=
rely-named)
 (defun %require-type (arg predsym)
   (if (funcall predsym arg)
@@ -320,7 +322,12 @@
     arg
     (%kernel-restart $xwrongtype arg (car type-cell))))
 =

-
+(defun require-structure-type (arg token)
+  (or(and (=3D (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
 ;;; builtin numeric types and predicates associated with them.