From aa01df7a18a5d8747423173bda7c20eb46092514 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri, 20 Apr 2012 17:04:32 +0300
Subject: [PATCH] teach IR1-TRANSFORM-TYPE-PREDICATE about alien types

  Convert to ALIEN-VALUE-TYPEP (new function). Avoids both the need to do the
  whole type parsing rigamarole at runtime, and checking for lisp-rep-type.

  Need to do this as late in the game as possible, because after we convert to
  ALIEN-VALUE-TYPEP, the rest of the system stops understanding it as a type
  test. (We really should have some sort of annotation for this sort of stuff,
  so we could convert whenever.)
---
 NEWS                           |    1 +
 package-data-list.lisp-expr    |    4 +++-
 src/code/target-alieneval.lisp |    4 ++++
 src/compiler/typetran.lisp     |   52 +++++++++++++++++++++++++---------------
 4 files changed, 41 insertions(+), 20 deletions(-)

diff --git a/NEWS b/NEWS
index 92a7af6..75b9204 100644
--- a/NEWS
+++ b/NEWS
@@ -7,6 +7,7 @@ changes relative to sbcl-1.0.56:
     called with too many arguments.
   * optimization: fewer uses of full calls to signed modular functions.
     (lp#903821)
+  * optimization: typechecking alien values is typically 5 x faster.
   * bug fix: fixed disassembly of some SSE instructions on x86-64.
   * bug fix: SB-SIMPLE-STREAMS signals an error for bogus :CLASS arguments in
     OPEN. (lp#969352, thanks to Kambiz Darabi)
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 2ef025b..a8c7825 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -97,7 +97,9 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
                "ALIEN-SINGLE-FLOAT-TYPE-P" "ALIEN-SUBTYPE-P" "ALIEN-TYPE"
                "ALIEN-TYPE-=" "ALIEN-TYPE-ALIGNMENT" "ALIEN-TYPE-BITS"
                "ALIEN-TYPE-P" "ALIEN-TYPEP"
-               "ALIEN-VALUE" "ALIEN-VALUE-TYPE"
+               "ALIEN-VALUE"
+               "ALIEN-VALUE-TYPE"
+               "ALIEN-VALUE-TYPEP"
                "ALIEN-VALUE-SAP" "ALIEN-VALUE-P"
                "ALIEN-VALUES-TYPE" "ALIEN-VALUES-TYPE-P"
                "ALIEN-VALUES-TYPE-VALUES" "ALIGN-OFFSET" "ALIEN-VOID-TYPE-P"
diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp
index aa7922f..a446c87 100644
--- a/src/code/target-alieneval.lisp
+++ b/src/code/target-alieneval.lisp
@@ -814,6 +814,10 @@ null byte.
         (and (alien-value-p object)
              (alien-subtype-p (alien-value-type object) type)))))
 
+(defun alien-value-typep (object type)
+  (when (alien-value-p object)
+    (alien-subtype-p (alien-value-type object) type)))
+
 ;;;; ALIEN CALLBACKS
 ;;;;
 ;;;; See "Foreign Linkage / Callbacks" in the SBCL Internals manual.
diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp
index 3c000d5..aeb9a7b 100644
--- a/src/compiler/typetran.lisp
+++ b/src/compiler/typetran.lisp
@@ -71,32 +71,46 @@
 ;;; If the lvar OBJECT definitely is or isn't of the specified
 ;;; type, then return T or NIL as appropriate. Otherwise quietly
 ;;; GIVE-UP-IR1-TRANSFORM.
-(defun ir1-transform-type-predicate (object type)
+(defun ir1-transform-type-predicate (object type node)
   (declare (type lvar object) (type ctype type))
   (let ((otype (lvar-type object)))
-    (cond ((not (types-equal-or-intersect otype type))
-           nil)
-          ((csubtypep otype type)
-           t)
-          ((eq type *empty-type*)
-           nil)
-          (t
-           (let ((intersect (type-intersection2 type otype)))
-             (unless intersect
-               (give-up-ir1-transform))
-             (multiple-value-bind (constantp value)
-                 (type-singleton-p intersect)
-               (if constantp
-                   `(eql object ',value)
-                   (give-up-ir1-transform))))))))
+    (flet ((tricky ()
+             (cond ((typep type 'alien-type-type)
+                    ;; We don't transform alien type tests until here, because
+                    ;; once we do that the rest of the type system can no longer
+                    ;; reason about them properly -- so we'd miss out on type
+                    ;; derivation, etc.
+                    (delay-ir1-transform node :optimize)
+                    (let ((alien-type (alien-type-type-alien-type type)))
+                      ;; If it's a lisp-rep-type, the CTYPE should be one already.
+                      (aver (not (compute-lisp-rep-type alien-type)))
+                      `(sb!alien::alien-value-typep object ',alien-type)))
+                   (t
+                    (give-up-ir1-transform)))))
+      (cond ((not (types-equal-or-intersect otype type))
+            nil)
+           ((csubtypep otype type)
+            t)
+           ((eq type *empty-type*)
+            nil)
+           (t
+            (let ((intersect (type-intersection2 type otype)))
+              (unless intersect
+                (tricky))
+              (multiple-value-bind (constantp value)
+                  (type-singleton-p intersect)
+                (if constantp
+                    `(eql object ',value)
+                    (tricky)))))))))
 
 ;;; Flush %TYPEP tests whose result is known at compile time.
-(deftransform %typep ((object type))
+(deftransform %typep ((object type) * * :node node)
   (unless (constant-lvar-p type)
     (give-up-ir1-transform))
   (ir1-transform-type-predicate
    object
-   (ir1-transform-specifier-type (lvar-value type))))
+   (ir1-transform-specifier-type (lvar-value type))
+   node))
 
 ;;; This is the IR1 transform for simple type predicates. It checks
 ;;; whether the single argument is known to (not) be of the
@@ -108,7 +122,7 @@
                            (basic-combination-fun node))))
                         *backend-predicate-types*)))
     (aver ctype)
-    (ir1-transform-type-predicate object ctype)))
+    (ir1-transform-type-predicate object ctype node)))
 
 ;;; If FIND-CLASSOID is called on a constant class, locate the
 ;;; CLASSOID-CELL at load time.
-- 
1.7.10.4