fix node splitter bug, fix typos in identities

library/alien/compiler.factor

@@ -159,8 +159,8 @@ M: compound (uncrossref)
         dup f "infer-effect" set-word-prop
         dup f "base-case" set-word-prop
         dup f "no-effect" set-word-prop
-        dup f "inline" set-word-prop
-        dup f "foldable" set-word-prop
-        dup f "flushable" set-word-prop
+        ! dup f "inline" set-word-prop
+        ! dup f "foldable" set-word-prop
+        ! dup f "flushable" set-word-prop
         decompile
     ] ifte ;

library/bootstrap/boot-stage2.factor

@@ -4,22 +4,6 @@ USING: alien assembler command-line compiler errors generic
 hashtables io kernel lists memory namespaces parser sequences
 unparser words ;
 
-: restarts. ( menu -- )
-    "Restarts:" print
-    dup length [ unparse print ". " write first print ] 2each
-    "> " write flush
-    ;
-
-: try-resource ( path -- )
-    "Loading " write dup print
-    [
-        run-resource
-    ] [
-        [
-            "Error loading resource. Restarts:" print
-        ] when*
-    ] catch ;
-
 : pull-in ( ? list -- )
     swap [
         [

library/bootstrap/boot-stage3.factor

@@ -35,7 +35,6 @@ init-assembler
 compile? [
     \ car compile
     \ * compile
-    \ length compile
     \ = compile
     \ unparse compile
     \ scan compile

library/inference/call-optimizers.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: inference
-USING: errors hashtables kernel sequences vectors words ;
+USING: errors hashtables kernel math math-internals sequences
+vectors words ;
 
 ! A system for associating dataflow optimizers with words.
 
@@ -57,9 +58,108 @@ M: #call optimize-node* ( node -- node/t )
         { [ t ] [ drop t ] }
     } cond ;
 
+! Arithmetic identities
 SYMBOL: @
 
-: values-match? ( spec values -- ? )
-    #! spec is a sequence of literals, or the symbol @ which is
-    #! a wildcard.
-    [ dup literal? [ drop @ ] unless = ] 2map conjunction ;
+: define-identities ( words identities -- )
+    swap [ swap "identities" set-word-prop ] each-with ;
+
+: literals-match? ( values template -- ? )
+    [
+        over literal? [ >r literal-value r> ] [ nip @ ] ifte =
+    ] 2map conjunction ;
+
+: values-match? ( values template -- ? )
+    [ @ = ] 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 ;
+
+[ + fixnum+ bignum+ float+ ] {
+    { { @ 0 } [ drop ] }
+    { { 0 @ } [ nip ]  }
+} define-identities
+
+[ - fixnum- bignum- float- ] {
+    { { @ 0 } [ drop ]    }
+    { { @ @ } [ 2drop 0 ] }
+} define-identities
+
+[ * fixnum* bignum* float* ] {
+    { { @ 1 }  [ drop ]          }
+    { { 1 @ }  [ nip ]           }
+    { { @ 0 }  [ 2drop 0 ]       }
+    { { 0 @ }  [ 2drop 0 ]       }
+    { { @ -1 } [ drop 0 swap - ] }
+    { { -1 @ } [ nip 0 swap - ]  }
+} define-identities
+
+[ / /i /f fixnum/i fixnum/f bignum/i bignum/f float/f ] {
+    { { @ 1 }  [ drop ]          }
+    { { @ -1 } [ drop 0 swap - ] }
+} define-identities
+
+[ rem mod fixnum-mod bignum-mod ] {
+    { { @ 1 }  [ 2drop 0 ] }
+} define-identities
+
+! [ ^ ] {
+!     { { 1 @ }  [ 2drop 1 ]             }
+!     { { @ 1 }  [ drop ]                }
+!     { { @ 2 }  [ drop dup * ]          }
+!     { { @ -1 } [ drop 1 swap / ]       }
+!     { { @ -2 } [ drop dup * 1 swap / ] }
+! } define-identities
+
+[ bitand fixnum-bitand bignum-bitand ] {
+    { { @ -1 } [ drop ]    }
+    { { -1 @ } [ nip  ]    }
+    { { @ @ }  [ drop ]    }
+    { { @ 0 }  [ 2drop 0 ] }
+    { { 0 @ }  [ 2drop 0 ] }
+} define-identities
+
+[ bitor fixnum-bitor bignum-bitor ] {
+    { { @ 0 }  [ drop ] }
+    { { 0 @ }  [ nip  ] }
+    { { @ @ }  [ drop ] }
+    { { @ -1 } [ 2drop -1 ] }
+    { { -1 @ } [ 2drop -1 ] }
+} define-identities
+
+[ bitxor fixnum-bitxor bignum-bitxor ] {
+    { { @ 0 }  [ drop ]        }
+    { { 0 @ }  [ nip  ]        }
+    { { @ -1 } [ drop bitnot ] }
+    { { -1 @ } [ nip  bitnot ] }
+    { { @ @ }  [ 2drop 0 ]     }
+} define-identities
+
+[ shift fixnum-shift bignum-shift ] {
+    { { 0 @ } [ 2drop 0 ] }
+    { { @ 0 } [ drop ] }
+} define-identities
+
+[ < fixnum< bignum< float< ] {
+    { { @ @ } [ 2drop f ] }
+} define-identities
+
+[ <= fixnum<= bignum<= float<= ] {
+    { { @ @ } [ 2drop t ] }
+} define-identities
+    
+[ > fixnum> bignum> float>= ] {
+    { { @ @ } [ 2drop f ] }
+} define-identities
+
+[ >= fixnum>= bignum>= float>= ] {
+    { { @ @ } [ 2drop t ] }
+} define-identities
+
+[ eq? number= = ] {
+    { { @ @ } [ 2drop t ] }
+} define-identities

library/inference/inline-methods.factor

@@ -57,7 +57,7 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
 : inline-method ( node -- node )
     dup method-dataflow [
         >r node-param r> remember-node
-    ] 2keep subst-node ;
+    ] 2keep [ subst-node ] keep ;
 
 : related? ( actual testing -- ? )
     #! If actual is a subset of testing or if the two classes

library/inference/known-words.factor

@@ -1,6 +1,7 @@
 IN: inference
-USING: errors generic interpreter kernel kernel-internals lists
-math math-internals parser sequences vectors words ;
+USING: errors generic hashtables interpreter kernel
+kernel-internals lists math math-internals parser sequences
+vectors words ;
 
 ! Primitive combinators
 \ call [
@@ -55,6 +56,7 @@ math math-internals parser sequences vectors words ;
 \ inference-error t "terminator" set-word-prop
 \ throw t "terminator" set-word-prop
 \ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
+\ hash-contained? [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop
 \ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop
 \ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop
 \ cdr [ [ general-list ] [ object ] ] "infer-effect" set-word-prop

library/inference/optimizer.factor

@@ -71,16 +71,12 @@ M: #ifte optimize-node* ( node -- node )
     [ literal-value 0 1 ? static-branch ] [ 2drop t ] ifte ;
 
 ! #values/#return
-: post-inline ( #return/#values #call/#merge -- node )
-    [ >r node-in-d r> node-out-d unify-length ] keep
-    node-successor [ subst-values ] keep ;
-
 : optimize-fold ( node -- node/t )
     #! Optimize #return/#call or #values/#merge, resulting from
     #! method inlining or branch folding, respectively.
-    dup node-successor dup [ post-inline ] [ 2drop t ] ifte ;
+    node-successor [ node-successor ] [ t ] ifte* ;
 
-M: #values optimize-node* ( node -- node ? )
+M: #values optimize-node* ( node -- node/t )
     optimize-fold ;
 
 M: #return optimize-node* ( node -- node/t )

library/inference/split-nodes.factor

@@ -37,16 +37,17 @@ M: #dispatch split-node* ( node -- )
 M: #label split-node* ( node -- )
     node-children first split-node ;
 
-: post-inline ( #return #call -- node )
-    [ >r node-in-d r> node-out-d ] keep
-    node-successor [ subst-values ] keep ;
+: post-inline ( #return/#values #call/#merge -- )
+    [ >r node-in-d r> node-out-d unify-length ] keep
+    node-successor subst-values ;
 
 : subst-node ( old new -- )
-    [ last-node set-node-successor ] keep dup split-node ;
+    [ last-node 2dup swap post-inline set-node-successor ] keep
+    split-node ;
 
 : inline-literals ( node literals -- node )
     #! Make #push -> #return -> successor
     over drop-inputs [
-        >r [ literalize ] map dataflow subst-node
+        >r [ literalize ] map dataflow [ subst-node ] keep
         r> set-node-successor
     ] keep ;

library/test/compiler/optimizer.factor

@@ -159,3 +159,9 @@ TUPLE: pred-test ;
     ] ifte ; compiled
 
 [ << pred-test >> "pred-test" ] [ << pred-test >> pred-test-4 ] unit-test
+
+: inline-test
+    "nom" = ; compiled
+
+[ t ] [ "nom" inline-test ] unit-test
+[ f ] [ 3 inline-test ] unit-test