Merge branch 'master' of git://factorcode.org/git/factor

core/bootstrap/compiler/compiler.factor

@@ -74,6 +74,12 @@ nl
     malloc free memcpy
 } compile
 
-[ compiled-usages recompile ] recompile-hook set-global
+: enable-compiler ( -- )
+    [ compiled-usages recompile ] recompile-hook set-global ;
+
+: disable-compiler ( -- )
+    [ [ f ] { } map>assoc modify-code-heap ] recompile-hook set-global ;
+
+enable-compiler
 
 " done" print flush

core/compiler/tests/stack-trace.factor

@@ -1,7 +1,7 @@
 IN: temporary
 USING: compiler tools.test namespaces sequences
 kernel.private kernel math continuations continuations.private
-words splitting ;
+words splitting sorting ;
 
 : symbolic-stack-trace ( -- newseq )
     error-continuation get continuation-call callstack>array
@@ -31,9 +31,9 @@ words splitting ;
     \ > stack-trace-contains?
 ] unit-test
 
-: quux [ t [ "hi" throw ] when ] times ;
+: quux { 1 2 3 } [ "hi" throw ] sort ;
 
 [ t ] [
     [ 10 quux ] ignore-errors
-    \ (each-integer) stack-trace-contains?
+    \ sort stack-trace-contains?
 ] unit-test

core/compiler/tests/templates-early.factor

@@ -44,7 +44,9 @@ words kernel math effects definitions compiler.units ;
 [
     [ ] [ init-templates ] unit-test
 
-    [ ] [ init-generator ] unit-test
+    H{ } clone compiled set
+
+    [ ] [ gensym gensym begin-compiling ] unit-test
 
     [ t ] [ [ end-basic-block ] { } make empty? ] unit-test
 

core/inference/dataflow/dataflow.factor

@@ -314,7 +314,7 @@ PREDICATE: #merge #tail-merge node-successor #tail? ;
 PREDICATE: #values #tail-values node-successor #tail? ;
 
 UNION: #tail
-    POSTPONE: f #return #tail-values #tail-merge ;
+    POSTPONE: f #return #tail-values #tail-merge #terminate ;
 
 : tail-call? ( -- ? )
     node-stack get [ node-successor #tail? ] all? ;

core/optimizer/backend/backend.factor

@@ -68,8 +68,6 @@ DEFER: optimize-nodes
         ] if
     ] when ;
 
-M: f set-node-successor 2drop ;
-
 : optimize-nodes ( node -- newnode )
     [
         class-substitutions [ clone ] change
@@ -81,16 +79,7 @@ M: f set-node-successor 2drop ;
 ! Generic nodes
 M: node optimize-node* drop t f ;
 
-: cleanup-inlining ( node -- newnode changed? )
-    node-successor [ node-successor t ] [ t f ] if* ;
-
-! #return
-M: #return optimize-node* cleanup-inlining ;
-
-! #values
-M: #values optimize-node* cleanup-inlining ;
-
-! Some utilities for splicing in dataflow IR subtrees
+! Post-inlining cleanup
 : follow ( key assoc -- value )
     2dup at* [ swap follow nip ] [ 2drop ] if ;
 
@@ -103,32 +92,31 @@ M: #values optimize-node* cleanup-inlining ;
     #! Not very efficient.
     dupd union* update ;
 
-: post-inline ( #call/#merge #return/#values -- assoc )
-    >r node-out-d r> node-in-d 2array unify-lengths flip
+: compute-value-substitutions ( #return/#values #call/#merge -- assoc )
+    node-out-d swap node-in-d 2array unify-lengths flip
     [ = not ] assoc-subset >hashtable ;
 
-: substitute-def-use ( node -- )
-    #! As a first approximation, we take all the values used
-    #! by the set of new nodes, and push a 't' on their
-    #! def-use list here. We could perform a full graph
-    #! substitution, but we don't need to, because the next
-    #! optimizer iteration will do that. We just need a minimal
-    #! degree of accuracy; the new values should be marked as
-    #! having _some_ usage, so that flushing doesn't erronously
-    #! flush them away.
-    [ compute-def-use def-use get keys ] with-scope
-    def-use get [ [ t swap ?push ] change-at ] curry each ;
+: cleanup-inlining ( #return/#values -- newnode changed? )
+    dup node-successor dup [
+        class-substitutions get pick node-classes update
+        literal-substitutions get pick node-literals update
+        tuck compute-value-substitutions value-substitutions get swap update*
+        node-successor t
+    ] [
+        2drop t f
+    ] if ;
 
-: substitute-node ( old new -- )
-    #! The last node of 'new' becomes 'old', then values are
-    #! substituted. A subsequent optimizer phase kills the
-    #! last node of 'new' and the first node of 'old'.
-    dup substitute-def-use
-    last-node
-    class-substitutions get over node-classes update
-    literal-substitutions get over node-literals update
-    2dup post-inline value-substitutions get swap update*
-    set-node-successor ;
+! #return
+M: #return optimize-node* cleanup-inlining ;
+
+! #values
+M: #values optimize-node* cleanup-inlining ;
+
+! Some utilities for splicing in dataflow IR subtrees
+M: f set-node-successor 2drop ;
+
+: splice-node ( old new -- )
+    dup splice-def-use last-node set-node-successor ;
 
 GENERIC: remember-method* ( method-spec node -- )
 
@@ -148,12 +136,12 @@ M: node remember-method*
     pick node-in-d dataflow-with
     [ remember-method ] keep
     [ swap infer-classes/node ] 2keep
-    [ substitute-node ] keep ;
+    [ splice-node ] keep ;
 
 : splice-quot ( #call quot -- node )
     over node-in-d dataflow-with
     [ swap infer-classes/node ] 2keep
-    [ substitute-node ] keep ;
+    [ splice-node ] keep ;
 
 : drop-inputs ( node -- #shuffle )
     node-in-d clone \ #shuffle in-node ;
@@ -161,7 +149,7 @@ M: node remember-method*
 ! Constant branch folding
 : fold-branch ( node branch# -- node )
     over node-children nth
-    swap node-successor over substitute-node ;
+    swap node-successor over splice-node ;
 
 ! #if
 : known-boolean-value? ( node value -- value ? )
@@ -176,23 +164,124 @@ M: node remember-method*
         } cond
     ] if ;
 
+: fold-if-branch? dup node-in-d first known-boolean-value? ;
+
+: fold-if-branch ( node value -- node' )
+    over drop-inputs >r
+    0 1 ? fold-branch
+    r> [ set-node-successor ] keep ;
+
+: only-one ( seq -- elt/f )
+    dup length 1 = [ first ] [ drop f ] if ;
+
+: lift-throw-tail? ( #if -- tail/? )
+    dup node-successor node-successor
+    [ active-children only-one ] [ drop f ] if ;
+
+: clone-node ( node -- newnode )
+    clone dup [ clone ] modify-values ;
+
+: detach-node-successor ( node -- successor )
+    dup node-successor #terminate rot set-node-successor ;
+
+: lift-branch ( #if node -- )
+    >r detach-node-successor r> splice-node ;
+
 M: #if optimize-node*
-    dup dup node-in-d first known-boolean-value? [
-        over drop-inputs >r
-        0 1 ? fold-branch
-        r> [ set-node-successor ] keep
-        t
-    ] [ 2drop t f ] if ;
+    dup fold-if-branch? [ fold-if-branch t ] [
+        2drop t f
+        ! drop dup lift-throw-tail? dup [
+        !     dupd lift-branch t
+        ! ] [
+        !     2drop t f
+        ! ] if
+    ] if ;
+
+: fold-dispatch-branch? dup node-in-d first tuck node-literal? ;
+
+: fold-dispatch-branch ( node value -- node' )
+    dupd node-literal
+    over drop-inputs >r fold-branch r>
+    [ set-node-successor ] keep ;
 
 M: #dispatch optimize-node*
-    dup dup node-in-d first 2dup node-literal? [
-        "Optimizing #dispatch" print
-        node-literal
-        over drop-inputs >r fold-branch r> [ set-node-successor ] keep t
+    dup fold-dispatch-branch? [
+        fold-dispatch-branch t
     ] [
-        3drop t f
+        2drop t f
     ] if ;
 
+! #loop
+
+
+! BEFORE:
+
+!   #label -> C -> #return 1
+!     |
+!     -> #if -> #merge -> #return 2
+!         |
+!     --------
+!     |      |
+!     A      B
+!     |      |
+!  #values   |
+!        #call-label
+!            |
+!            |
+!         #values
+
+! AFTER:
+
+!    #label -> #terminate
+!     |
+!     -> #if -> #terminate
+!         |
+!     --------
+!     |      |
+!     A      B
+!     |      |
+!  #values   |
+!     |  #call-label
+!  #merge    |
+!     |      |
+!     C   #values
+!     |
+!  #return 1
+
+: find-final-if ( node -- #if/f )
+    dup [
+        dup #if? [
+            dup node-successor #tail? [
+                node-successor find-final-if
+            ] unless
+        ] [
+            node-successor find-final-if
+        ] if
+    ] when ;
+
+: lift-loop-tail? ( #label -- tail/f )
+    dup node-successor node-successor [
+        dup node-param swap node-child find-final-if dup [
+            node-children [ penultimate-node ] map
+            [
+                dup #call-label?
+                [ node-param eq? not ] [ 2drop t ] if
+            ] with subset only-one
+        ] [ 2drop f ] if
+    ] [ drop f ] if ;
+
+! M: #loop optimize-node*
+!     dup lift-loop-tail? dup [
+!         last-node >r
+!         dup detach-node-successor
+!         over node-child find-final-if detach-node-successor
+!         [ set-node-successor ] keep
+!         r> set-node-successor
+!         t
+!     ] [
+!         2drop t f
+!     ] if ;
+
 ! #call
 : splice-method ( #call method-spec/t quot/t -- node/t )
     #! t indicates failure

core/optimizer/def-use/def-use.factor

@@ -70,20 +70,6 @@ M: #branch node-def-use
     #! #values node.
     dup branch-def-use (node-def-use) ;
 
-! : dead-literals ( -- values )
-!     def-use get [ >r value? r> empty? and ] assoc-subset ;
-! 
-! : kill-node* ( node values -- )
-!     [ swap remove-all ] curry modify-values ;
-! 
-! : kill-node ( node values -- )
-!     dup assoc-empty?
-!     [ 2drop ] [ [ kill-node* ] curry each-node ] if ;
-! 
-! : kill-values ( node -- )
-!     #! Remove literals which are not actually used anywhere.
-!     dead-literals kill-node ;
-
 : compute-dead-literals ( -- values )
     def-use get [ >r value? r> empty? and ] assoc-subset ;
 
@@ -129,8 +115,18 @@ M: #r> kill-node* [ node-in-r empty? ] prune-if ;
         dead-literals [ kill-nodes ] with-variable
     ] if ;
 
-!
-
 : sole-consumer ( #call -- node/f )
     node-out-d first used-by
     dup length 1 = [ first ] [ drop f ] if ;
+
+: splice-def-use ( node -- )
+    #! As a first approximation, we take all the values used
+    #! by the set of new nodes, and push a 't' on their
+    #! def-use list here. We could perform a full graph
+    #! substitution, but we don't need to, because the next
+    #! optimizer iteration will do that. We just need a minimal
+    #! degree of accuracy; the new values should be marked as
+    #! having _some_ usage, so that flushing doesn't erronously
+    #! flush them away.
+    [ compute-def-use def-use get keys ] with-scope
+    def-use get [ [ t swap ?push ] change-at ] curry each ;

core/optimizer/optimizer.factor

@@ -12,7 +12,7 @@ IN: optimizer
         H{ } clone value-substitutions set
         dup compute-def-use
         kill-values
-        ! dup detect-loops
+        dup detect-loops
         dup infer-classes
         optimizer-changed off
         optimize-nodes

core/optimizer/specializers/specializers.factor

@@ -24,7 +24,7 @@ IN: optimizer.specializers
         \ dispatch ,
     ] [ ] make ;
 
-: specializer-methods ( word -- alist )
+: specializer-methods ( quot word -- default alist )
     dup [ array? ] all? [ 1array ] unless [
         [ make-specializer ] keep
         [ declare ] curry pick append

extra/benchmark/benchmark.factor

@@ -8,7 +8,7 @@ IN: benchmark
 : run-benchmark ( vocab -- result )
     "=== Benchmark " write dup print flush
     dup require
-    [ [ run ] benchmark ] [ error. f f ] recover 2array
+    [ [ run ] benchmark ] [ error. drop f f ] recover 2array
     dup . ;
 
 : run-benchmarks ( -- assoc )

extra/optimizer/debugger/debugger.factor

@@ -95,14 +95,18 @@ M: #dispatch node>quot
     node-children swap [ dataflow>quot ] curry map ,
     \ dispatch , ;
 
-M: #return node>quot
-    dup node-param unparse "#return " swap append comment, ;
-
 M: #>r node>quot nip node-in-d length \ >r <array> % ;
 
 M: #r> node>quot nip node-out-d length \ r> <array> % ;
 
-M: object node>quot dup class word-name comment, ;
+M: object node>quot
+    [
+        dup class word-name %
+        " " %
+        dup node-param unparse %
+        " " %
+        dup effect-str %
+    ] "" make comment, ;
 
 : (dataflow>quot) ( ? node -- )
     dup [