collapse slice of a slice; %fast-set-slot linearizer was buggy

CHANGES.html

@@ -12,6 +12,9 @@
 <li>Optimizing out conditionals where the test value is a constant.</li>
 <li>Optimizing out type checks that are always/never satisfied.</li>
 <li>Inlining method bodies when generic words are called on values with known compile-time types.</li>
+<li>Side-effect-free words that output immutable values are evaluated at compile time if all their inputs are literal. You can declare a word as having this condition by suffixing the definition with <code>foldable</code>, eg:
+<pre>: cube dup dup * * ; foldable</pre></li>
+<li>Various arithmetic identities such as <code>1 *</code> are optimized out.
 </ul>
 
 </li>

library/collections/virtual-sequences.factor

@@ -26,7 +26,12 @@ M: reversed thaw ( seq -- seq ) delegate reverse ;
 ! A slice of another sequence.
 TUPLE: slice seq from to step ;
 
+: collapse-slice ( from to slice -- from to seq )
+    dup slice-from swap slice-seq >r tuck + >r + r> r> ;
+
 C: slice ( from to seq -- seq )
+    #! A slice of a slice collapses.
+    >r dup slice? [ collapse-slice ] when r>
     [ set-slice-seq ] keep
     >r 2dup > -1 1 ? r>
     [ set-slice-step ] keep

library/compiler/intrinsics.factor

@@ -54,28 +54,28 @@ sequences vectors words ;
     out-1
 ] "intrinsic" set-word-prop
 
-: value-types drop f ;
+: node-peek ( node -- value ) node-in-d peek ;
 
-: node-peek ( node -- obj ) node-in-d peek ;
+: value-tag ( value node -- n/f )
+    #! If the tag is known, output it, otherwise f.
+    node-classes hash dup [
+        types [ type-tag ] map dup [ = ] every?
+        [ first ] [ drop f ] ifte
+    ] [
+        drop f
+    ] ifte ;
 
-: peek-2 dup length 2 - swap nth ;
+: slot@ ( node -- n/f )
-: node-peek-2 ( node -- obj ) node-in-d peek-2 ;
-
-: typed? ( value -- ? ) value-types length 1 = ;
-
-: slot@ ( node -- n )
     #! Compute slot offset.
-    node-in-d
+    dup node-in-d reverse dup first dup literal? [
-    dup peek literal-value cell *
+        literal-value cell * swap second
-    swap peek-2 value-types car type-tag - ;
+        rot value-tag dup [ - ] [ 2drop f ] ifte
-
+    ] [
-: typed-literal? ( node -- ? )
+        3drop f
-    #! Output if the node's first input is well-typed, and the
+    ] ifte ;
-    #! second is a literal.
-    dup node-peek literal? swap node-peek-2 typed? and ;
 
 \ slot [
-    dup typed-literal? [
+    dup slot@ [
         1 %dec-d ,
         in-1
         0 swap slot@ %fast-slot ,
@@ -89,20 +89,19 @@ sequences vectors words ;
 ] "intrinsic" set-word-prop
 
 \ set-slot [
-    dup typed-literal? [
+    dup slot@ [
         1 %dec-d ,
         in-2
         2 %dec-d ,
         slot@ >r 0 1 r> %fast-set-slot ,
-        0 %write-barrier ,
     ] [
         drop
         in-3
         3 %dec-d ,
         1 %untag ,
         0 1 2 %set-slot ,
-        1 %write-barrier ,
     ] ifte
+    1 %write-barrier ,
 ] "intrinsic" set-word-prop
 
 \ type [

library/generic/generic.factor

@@ -36,6 +36,8 @@ SYMBOL: null
     #! Test if class1 is a subclass of class2.
     {
         { [ 2dup eq? ] [ 2drop t ] }
+        { [ over types empty? ] [ 2drop t ] }
+        { [ dup types empty? ] [ 2drop f ] }
         { [ dup custom-class< ] [ dup custom-class< call ] }
         { [ t ] [ 2types contained? ] }
     } cond ;

library/generic/predicate.factor

@@ -31,7 +31,7 @@ predicate [
     over metaclass over metaclass eq? [
         >r "superclass" word-prop r> class<
     ] [
-        drop types empty?
+        2drop f
     ] ifte
 ] "class<" set-word-prop
 

library/test/compiler/intrinsics.factor

@@ -12,6 +12,9 @@ math-internals test words ;
 [ 3 ] [ 3 1 2 [ cons [ 1 set-slot ] keep ] compile-1 cdr ] unit-test
 [ 3 ] [ [ 3 1 2 cons [ 1 set-slot ] keep ] compile-1 cdr ] unit-test
 
+! Write barrier hits on the wrong value were causing segfaults
+[ -3 ] [ -3 1 2 [ cons [ 1 set-slot ] keep ] compile-1 cdr ] unit-test
+
 [ ] [ 1 [ drop ] compile-1 ] unit-test
 [ ] [ [ 1 drop ] compile-1 ] unit-test
 [ ] [ [ 1 2 2drop ] compile-1 ] unit-test

library/test/sequences.factor

@@ -8,8 +8,8 @@ USING: kernel lists math sequences strings test vectors ;
 [ { 2 3 } ] [ 1 3 { 1 2 3 4 } <slice> >vector ] unit-test
 [ { 4 5 } ] [ 2 { 1 2 3 4 5 } tail-slice* >vector ] unit-test
 [ { 1 2 } { 3 4 } ] [ 2 { 1 2 3 4 } cut ] unit-test
-[ { 3 4 } ] [ 2 4 1 10 <range> subseq ] unit-test
+[ { 3 4 } ] [ 2 4 1 10 <range> subseq >vector ] unit-test
-[ { 3 4 } ] [ 0 2 2 4 1 10 <range> <slice> subseq ] unit-test
+[ { 3 4 } ] [ 0 2 2 4 1 10 <range> <slice> subseq >vector ] unit-test
 [ "cba" ] [ 3 "abcdef" head-slice reverse ] unit-test
 
 [ 1 2 3 ] [ 1 2 3 3vector 3unseq ] unit-test

library/test/test.factor

@@ -72,7 +72,7 @@ SYMBOL: failures
     prepare-tests [ test ] subset terpri passed. failed. ;
 
 : tests
-    [
+    {
         "lists/cons" "lists/lists" "lists/assoc"
         "lists/namespaces" "lists/queues"
         "combinators"
@@ -91,26 +91,26 @@ SYMBOL: failures
         "gadgets/gradients" "memory"
         "redefine" "annotate" "sequences" "binary" "inspector"
         "kernel"
-    ] run-tests ;
+    } run-tests ;
 
 : benchmarks
-    [
+    {
         "benchmark/empty-loop" "benchmark/fac"
         "benchmark/fib" "benchmark/sort"
         "benchmark/continuations" "benchmark/ack"
         "benchmark/hashtables" "benchmark/strings"
         "benchmark/vectors" "benchmark/prettyprint"
         "benchmark/image"
-    ] run-tests ;
+    } run-tests ;
 
 : compiler-tests
-    [
+    {
         "io/buffer" "compiler/optimizer"
         "compiler/simple"
         "compiler/stack" "compiler/ifte"
         "compiler/generic" "compiler/bail-out"
         "compiler/linearizer" "compiler/intrinsics"
         "compiler/identities"
-    ] run-tests ;
+    } run-tests ;
 
 : all-tests tests compiler-tests benchmarks ;