diff --git a/CHANGES.html b/CHANGES.html
index 46567205c2..23b73760e5 100644
--- a/CHANGES.html
+++ b/CHANGES.html
@@ -12,6 +12,9 @@
Optimizing out conditionals where the test value is a constant.
Optimizing out type checks that are always/never satisfied.
Inlining method bodies when generic words are called on values with known compile-time types.
+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 foldable
, eg:
+: cube dup dup * * ; foldable
+Various arithmetic identities such as 1 *
are optimized out.
diff --git a/library/collections/virtual-sequences.factor b/library/collections/virtual-sequences.factor
index 6f7ce9bd0c..76aab05cc9 100644
--- a/library/collections/virtual-sequences.factor
+++ b/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
diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index 658bb83e29..b73149e6fb 100644
--- a/library/compiler/intrinsics.factor
+++ b/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 ;
-: node-peek-2 ( node -- obj ) node-in-d peek-2 ;
-
-: typed? ( value -- ? ) value-types length 1 = ;
-
-: slot@ ( node -- n )
+: slot@ ( node -- n/f )
#! Compute slot offset.
- node-in-d
- dup peek literal-value cell *
- swap peek-2 value-types car type-tag - ;
-
-: typed-literal? ( node -- ? )
- #! Output if the node's first input is well-typed, and the
- #! second is a literal.
- dup node-peek literal? swap node-peek-2 typed? and ;
+ dup node-in-d reverse dup first dup literal? [
+ literal-value cell * swap second
+ rot value-tag dup [ - ] [ 2drop f ] ifte
+ ] [
+ 3drop f
+ ] ifte ;
\ 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 [
diff --git a/library/generic/generic.factor b/library/generic/generic.factor
index 17d94d46d8..ce2e0256ac 100644
--- a/library/generic/generic.factor
+++ b/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 ;
diff --git a/library/generic/predicate.factor b/library/generic/predicate.factor
index bc242b65d3..4acf916c17 100644
--- a/library/generic/predicate.factor
+++ b/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
diff --git a/library/test/compiler/intrinsics.factor b/library/test/compiler/intrinsics.factor
index 07e708dc63..6896328cd6 100644
--- a/library/test/compiler/intrinsics.factor
+++ b/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
diff --git a/library/test/sequences.factor b/library/test/sequences.factor
index a28fd0657c..70f7b361c5 100644
--- a/library/test/sequences.factor
+++ b/library/test/sequences.factor
@@ -8,8 +8,8 @@ USING: kernel lists math sequences strings test vectors ;
[ { 2 3 } ] [ 1 3 { 1 2 3 4 } >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 subseq ] unit-test
-[ { 3 4 } ] [ 0 2 2 4 1 10 subseq ] unit-test
+[ { 3 4 } ] [ 2 4 1 10 subseq >vector ] unit-test
+[ { 3 4 } ] [ 0 2 2 4 1 10 subseq >vector ] unit-test
[ "cba" ] [ 3 "abcdef" head-slice reverse ] unit-test
[ 1 2 3 ] [ 1 2 3 3vector 3unseq ] unit-test
diff --git a/library/test/test.factor b/library/test/test.factor
index e54e71b3c2..e3e095006d 100644
--- a/library/test/test.factor
+++ b/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 ;