instance? optimizes null checks

diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 17701e94c1a8cd604ca3852711cc1faa2824c988..8c470bf6a28f3986adbc12635ececeb8988a2409 100644 (file)
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -976,3 +976,21 @@ M: tuple-with-read-only-slot clone
     ! Should actually be 0 23 2^ 1 - [a,b]
     [ string-nth ] final-info first interval>> 0 23 2^ [a,b] =
 ] unit-test
+
+! Optimization on instance?
+[ f ] [ [ { number } declare fixnum instance? ] { tag fixnum? } inlined? ] unit-test
+
+UNION: ?fixnum fixnum POSTPONE: f ;
+[ t ] [ [ { ?fixnum } declare fixnum instance? ] { tag fixnum? } inlined? ] unit-test
+[ t ] [ [ { fixnum } declare fixnum instance? ] { tag fixnum? } inlined? ] unit-test
+
+! Actually check to make sure that the generated code works properly
+: instance-test-1 ( x -- ? ) { ?fixnum } declare fixnum instance? ;
+: instance-test-2 ( x -- ? ) { number } declare fixnum instance? ;
+: instance-test-3 ( x -- ? ) { POSTPONE: f } declare \ f instance? ;
+
+[ t ] [ 1 instance-test-1 ] unit-test
+[ f ] [ f instance-test-1 ] unit-test
+[ t ] [ 1 instance-test-2 ] unit-test
+[ f ] [ 1.1 instance-test-2 ] unit-test
+[ t ] [ f instance-test-3 ] unit-test

diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor
index 3d2d7ac298c17d42ed59abac16b300aec34b15c7..bd85882982854bbe5e4746486afecded8e566762 100644 (file)
--- a/basis/compiler/tree/propagation/transforms/transforms.factor
+++ b/basis/compiler/tree/propagation/transforms/transforms.factor
@@ -141,6 +141,19 @@ IN: compiler.tree.propagation.transforms
     } case
 ] "custom-inlining" set-word-prop
 
+:: inline-instance ( node -- quot/f )
+    node in-d>> first2 [ value-info ] bi@ literal>> :> ( obj klass )
+    klass class? [
+        {
+            [ klass \ f = not ]
+            [ obj class>> \ f class-not class-and klass class<= ]
+        } 0&&
+        [ [ drop >boolean ] ]
+        [ klass "predicate" word-prop '[ drop @ ] ] if
+    ] [ f ] if ;
+
+\ instance? [ inline-instance ] "custom-inlining" set-word-prop
+
 ERROR: bad-partial-eval quot word ;
 
 : check-effect ( quot word -- )
@@ -173,11 +186,6 @@ ERROR: bad-partial-eval quot word ;
 
 \ new [ inline-new ] 1 define-partial-eval
 
-\ instance? [
-    dup class?
-    [ "predicate" word-prop ] [ drop f ] if
-] 1 define-partial-eval
-
 ! Shuffling
 : nths-quot ( indices -- quot )
     [ [ '[ _ swap nth ] ] map ] [ length ] bi