arithmetic identities

TODO.FACTOR.txt

@@ -73,13 +73,9 @@
 - recursion is iffy; no base case needs to throw an error, and if the
   stack at the recursive call doesn't match up, throw an error
 
-+ sequences
-
-- array sort
-- specialized arrays
-
 + kernel:
 
+- specialized arrays
 - clear "predicating" word prop when redefining words
 - there is a problem with hashcodes of words and bootstrapping
 - delegating generic words with a non-standard picker

library/compiler/compiler.factor

@@ -60,3 +60,6 @@ M: compound (compile) ( word -- )
 
 : recompile ( word -- )
     dup decompile compile ;
+
+: compile-1 ( quot -- word )
+    gensym [ swap define-compound ] keep dup compile execute ;

library/inference/call-optimizers.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: inference
-USING: errors hashtables kernel math math-internals sequences
-vectors words ;
+USING: errors generic hashtables kernel math math-internals
+sequences vectors words ;
 
 ! A system for associating dataflow optimizers with words.
 
@@ -48,15 +48,13 @@ vectors words ;
     { [ dup node-successor #ifte? ] [ node-successor dup flip-branches ] }
 } define-optimizers
 
-M: #call optimize-node* ( node -- node/t )
-    {
-        { [ dup node-param not ] [ node-successor ] }
-        { [ dup partial-eval? ] [ partial-eval ] }
-        { [ dup optimizer-hooks ] [ optimize-hooks ] }
-        { [ dup inlining-class ] [ inline-method ] }
-        { [ dup optimize-predicate? ] [ optimize-predicate ] }
-        { [ t ] [ drop t ] }
-    } cond ;
+: disjoint-eq? ( node -- ? )
+    dup node-classes swap node-in-d [ swap hash ] map-with
+    2unseq class-and null = ;
+
+\ eq? {
+    { [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
+} define-optimizers
 
 ! Arithmetic identities
 SYMBOL: @
@@ -70,14 +68,21 @@ SYMBOL: @
     ] 2map conjunction ;
 
 : values-match? ( values template -- ? )
-    [ @ = ] 2map [ ] subset [ eq? ] every? ;
+    [ @ = [ drop f ] unless ] 2map [ ] subset [ eq? ] every? ;
 
 : apply-identity? ( values identity -- ? )
     first 2dup literals-match? >r values-match? r> and ;
 
-: apply-identities ( values identities -- node/f )
-    dupd [ apply-identity? ] find-with nip dup
-    [ second swap dataflow-with ] [ 2drop f ] ifte ;
+: find-identity ( node -- values identity )
+    dup node-in-d swap node-param "identities" word-prop
+    [ dupd apply-identity? ] find nip ;
+
+: apply-identities ( node -- node/f )
+    dup find-identity dup [
+        second swap dataflow-with [ subst-node ] keep
+    ] [
+        3drop f
+    ] ifte ;
 
 [ + fixnum+ bignum+ float+ ] {
     { { @ 0 } [ drop ] }
@@ -92,8 +97,8 @@ SYMBOL: @
 [ * fixnum* bignum* float* ] {
     { { @ 1 }  [ drop ]          }
     { { 1 @ }  [ nip ]           }
-    { { @ 0 }  [ 2drop 0 ]       }
-    { { 0 @ }  [ 2drop 0 ]       }
+    { { @ 0 }  [ nip ]           }
+    { { 0 @ }  [ drop ]          }
     { { @ -1 } [ drop 0 swap - ] }
     { { -1 @ } [ nip 0 swap - ]  }
 } define-identities
@@ -119,16 +124,16 @@ SYMBOL: @
     { { @ -1 } [ drop ] }
     { { -1 @ } [ nip  ] }
     { { @ @ }  [ drop ] }
-    { { @ 0 }  [ 2drop 0 ] }
-    { { 0 @ }  [ 2drop 0 ] }
+    { { @ 0 }  [ nip  ] }
+    { { 0 @ }  [ drop ] }
 } define-identities
 
 [ bitor fixnum-bitor bignum-bitor ] {
     { { @ 0 }  [ drop ] }
     { { 0 @ }  [ nip  ] }
     { { @ @ }  [ drop ] }
-    { { @ -1 } [ 2drop -1 ] }
-    { { -1 @ } [ 2drop -1 ] }
+    { { @ -1 } [ nip  ] }
+    { { -1 @ } [ drop ] }
 } define-identities
 
 [ bitxor fixnum-bitxor bignum-bitxor ] {
@@ -140,7 +145,7 @@ SYMBOL: @
 } define-identities
 
 [ shift fixnum-shift bignum-shift ] {
-    { { 0 @ } [ 2drop 0 ] }
+    { { 0 @ } [ drop ] }
     { { @ 0 } [ drop ] }
 } define-identities
 
@@ -163,3 +168,14 @@ SYMBOL: @
 [ eq? number= = ] {
     { { @ @ } [ 2drop t ] }
 } define-identities
+
+M: #call optimize-node* ( node -- node/t )
+    {
+        { [ dup node-param not ] [ node-successor ] }
+        { [ dup partial-eval? ] [ partial-eval ] }
+        { [ dup find-identity nip ] [ apply-identities ] }
+        { [ dup optimizer-hooks ] [ optimize-hooks ] }
+        { [ dup inlining-class ] [ inline-method ] }
+        { [ dup optimize-predicate? ] [ optimize-predicate ] }
+        { [ t ] [ drop t ] }
+    } cond ;

library/test/benchmark/sort.factor

@@ -1,13 +1,7 @@
 IN: temporary
-USE: lists
-USE: kernel
-USE: math
-USE: namespaces
-USE: random
-USE: test
-USE: compiler
+USING: compiler kernel math sequences test ;
 
 : sort-benchmark
-    [ 100000 [ 0 10000 random-int , ] times ] make-vector [ - ] sort drop ; compiled
+    100000 [ drop 0 10000 random-int ] map [ - ] sort drop ; compiled
 
 [ ] [ sort-benchmark ] unit-test

library/test/compiler/intrinsics.factor

@@ -3,9 +3,6 @@ USING: compiler kernel kernel-internals lists math
 math-internals test words ;
 
 ! Make sure that intrinsic ops compile to correct code.
-: compile-1 ( quot -- word )
-    gensym [ swap define-compound ] keep dup compile execute ;
-
 [ 1 ] [ [[ 1 2 ]] [ 0 slot ] compile-1 ] unit-test
 [ 1 ] [ [ [[ 1 2 ]] 0 slot ] compile-1 ] unit-test
 [ 3 ] [ 3 1 2 cons [ [ 0 set-slot ] keep ] compile-1 car ] unit-test

library/ui/splitters.factor

@@ -48,12 +48,12 @@ C: splitter ( first second split vector -- splitter )
     dup splitter-split swap rectangle-dim
     n*v divider-size 1/2 v*n v- ;
 
-: splitter-layout ( splitter -- [ a b c ] )
+: splitter-layout ( splitter -- { a b c } )
     [
         dup splitter-part ,
         divider-size ,
         dup rectangle-dim divider-size v- swap splitter-part v- ,
-    ] make-list ;
+    ] make-vector ;
 
 M: splitter layout* ( splitter -- )
     dup splitter-layout packed-layout ;