partial evaluation of branches

library/cli.factor

@@ -85,11 +85,12 @@ USE: kernel-internals
 : default-cli-args
     #! Some flags are *on* by default, unless user specifies
     #! -no-<flag> CLI switch
-    t "user-init" set
+    "user-init" on
-    t "interactive" set
+    "interactive" on
-    t "smart-terminal" set
+    "smart-terminal" on
-    t "verbose-compile" set
+    "verbose-compile" on
-    t "compile" set ;
+    "compile" on
+    os "win32" = [ "graphical" on ] when ;
 
 : cli-args ( -- args ) 10 getenv ;
 

library/compiler/compiler.factor

@@ -41,6 +41,7 @@ USE: strings
 USE: unparser
 USE: vectors
 USE: words
+USE: test
 
 : supported-cpu? ( -- ? )
     cpu "unknown" = not ;
@@ -97,7 +98,7 @@ M: compound (compile) ( word -- )
 : compile-all ( -- )
     #! Compile all words.
     supported-cpu? [
-        [ try-compile ] each-word
+        [ [ try-compile ] each-word ] time
     ] [
         "Unsupported CPU" print
     ] ifte ;

library/inference/branches.factor

@@ -39,6 +39,10 @@ USE: words
 USE: hashtables
 USE: prettyprint
 
+! If this symbol is on, partial evalution of conditionals is
+! disabled.
+SYMBOL: inferring-base-case
+
 : vector-length< ( vec1 vec2 -- ? )
     swap vector-length swap vector-length < ;
 
@@ -127,9 +131,8 @@ SYMBOL: cloned
     d-in [ deep-clone-vector ] change
     dataflow-graph off ;
 
-: infer-branch ( value save-effect -- namespace )
+: infer-branch ( value -- namespace )
     <namespace> [
-        save-effect set
         uncons [ unswons [ \ value-class set ] bind ] when*
         dup value-recursion recursive-state set
         copy-inference
@@ -154,7 +157,7 @@ SYMBOL: dual-recursive-state
     #! Return effect namespace if inference didn't fail.
     [
         [ dual-branch dual-recursive-state set ] keep
-        f infer-branch
+        infer-branch
     ] [
         [ 2drop f ] when
     ] catch ;
@@ -167,12 +170,16 @@ SYMBOL: dual-recursive-state
     #! Either the word is not recursive, or it is recursive
     #! and the base case throws an error.
     [
+        inferring-base-case on
+
         [ terminator-quot? not ] subset dup length 1 > [
             infer-base-cases unify-effects
             effect dual-recursive-state get set-base
         ] [
             drop
         ] ifte
+        
+        inferring-base-case off
     ] with-scope ;
 
 : (infer-branches) ( branchlist -- list )
@@ -182,7 +189,7 @@ SYMBOL: dual-recursive-state
     #! is a pair [ value | class ] indicating a type propagation
     #! for the given branch.
     dup infer-base-case [
-        dup t infer-branch swap terminator-quot? [
+        dup infer-branch swap terminator-quot? [
             [ meta-d off meta-r off d-in off ] extend
         ] when
     ] map ;
@@ -198,11 +205,17 @@ SYMBOL: dual-recursive-state
     #! parameter is a vector.
     (infer-branches) dup unify-effects unify-dataflow ;
 
+: static-branch? ( value -- )
+    literal? inferring-base-case get not and ;
+
 : static-ifte ( true false -- )
     #! If the branch taken is statically known, just infer
     #! along that branch.
-    pop-d literal-value [ drop ] [ nip ] ifte
+    dataflow-drop, pop-d literal-value [ drop ] [ nip ] ifte
-    literal-value infer-quot ;
+    gensym [
+        dup value-recursion recursive-state set
+        literal-value infer-quot
+    ] (with-block) ;
 
 : dynamic-ifte ( true false -- )
     #! If branch taken is computed, infer along both paths and
@@ -219,11 +232,11 @@ SYMBOL: dual-recursive-state
     [ object general-list general-list ] ensure-d
     dataflow-drop, pop-d
     dataflow-drop, pop-d swap
-!    peek-d literal? [
+    peek-d static-branch? [
-!        static-ifte
+        static-ifte
-!    ] [
+    ] [
-        dynamic-ifte ;
+        dynamic-ifte
-!    ] ifte ;
+    ] ifte ;
 
 \ ifte [ infer-ifte ] "infer" set-word-property
 

library/inference/inference.factor

@@ -59,12 +59,6 @@ SYMBOL: entry-effect
 ! makes a local jump to this label.
 SYMBOL: recursive-label
 
-! When inferring stack effects of mutually recursive words, we
-! don't want to save the fact that one word does not have a
-! stack effect before the base case of its mutual pair is
-! inferred.
-SYMBOL: save-effect
-
 ! A value has the following slots:
 GENERIC: literal-value ( value -- obj )
 GENERIC: value= ( literal value -- ? )
@@ -149,8 +143,7 @@ M: literal value-class-and ( class value -- )
     init-interpreter
     0 <vector> d-in set
     recursive-state set
-    dataflow-graph off
+    dataflow-graph off ;
-    save-effect on ;
 
 DEFER: apply-word
 

library/inference/words.factor

@@ -109,29 +109,14 @@ USE: prettyprint
         [ swap <chained-error> rethrow ] when*
     ] catch ;
 
-: (infer-compound) ( word -- effect )
+: infer-compound ( word -- effect )
     #! Infer a word's stack effect in a separate inferencer
     #! instance.
     [
         recursive-state get init-inference
-        dup inline-compound
+        dup dup inline-compound
         [ "infer-effect" set-word-property ] keep
-    ] with-scope ;
+    ] with-scope consume/produce ;
-
-: infer-compound ( word -- )
-    #! Infer the stack effect of a compound word in a separate
-    #! inferencer instance, caching the result.
-    [
-        dup (infer-compound) consume/produce
-    ] [
-        [
-            swap save-effect get [
-                t "no-effect" set-word-property
-            ] [
-                drop
-            ] ifte rethrow
-        ] when*
-    ] catch ;
 
 GENERIC: (apply-word)
 

library/test/inference.factor

@@ -41,7 +41,6 @@ USE: generic
 [ [ call ] infer old-effect ] unit-test-fails
 
 [ [ 2 | 4 ] ] [ [ 2dup ] infer old-effect ] unit-test
-[ [ 2 | 0 ] ] [ [ set-vector-length ] infer old-effect ] unit-test
 [ [ 2 | 0 ] ] [ [ vector-push ] infer old-effect ] unit-test
 
 [ [ 1 | 0 ] ] [ [ [ ] [ ] ifte ] infer old-effect ] unit-test
@@ -99,6 +98,13 @@ USE: generic
 
 [ [ bad-recursion-2 ] infer old-effect ] unit-test-fails
 
+! Not sure how to fix this one
+
+! : funny-recursion
+!     dup [ funny-recursion 1 ] [ 2 ] ifte drop ;
+! 
+! [ [ 1 | 1 ] ] [ [ funny-recursion ] infer old-effect ] unit-test
+
 ! Simple combinators
 [ [ 1 | 2 ] ] [ [ [ car ] keep cdr ] infer old-effect ] unit-test
 
@@ -123,6 +129,9 @@ DEFER: foe
         2drop f
     ] ifte ;
 
+[ [ 2 | 1 ] ] [ [ fie ] infer old-effect ] unit-test
+[ [ 2 | 1 ] ] [ [ foe ] infer old-effect ] unit-test
+
 ! This form should not have a stack effect
 : bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] ifte ;
 [ [ bad-bin ] infer old-effect ] unit-test-fails
@@ -149,9 +158,8 @@ SYMBOL: sym-test
 
 [ [ 0 | 1 ] ] [ [ sym-test ] infer old-effect ] unit-test
 
-[ [ 2 | 1 ] ] [ [ fie ] infer old-effect ] unit-test
-[ [ 2 | 1 ] ] [ [ foe ] infer old-effect ] unit-test
 
+[ [ 2 | 0 ] ] [ [ set-vector-length ] infer old-effect ] unit-test
 [ [ 2 | 1 ] ] [ [ 2list ] infer old-effect ] unit-test
 [ [ 3 | 1 ] ] [ [ 3list ] infer old-effect ] unit-test
 [ [ 2 | 1 ] ] [ [ append ] infer old-effect ] unit-test