Phasing out basic block optimizer; moved %inc-d/r merge optimization to templates

library/alien/alien-callback.factor

@@ -60,7 +60,7 @@ M: alien-callback-error summary ( error -- )
     ] make-linear ;
 
 M: alien-callback linearize* ( node -- )
-    compile-gc linearize-callback iterate-next ;
+    end-basic-block compile-gc linearize-callback iterate-next ;
 
 M: alien-callback stack-reserve*
     alien-callback-parameters stack-space ;

library/alien/alien-invoke.factor

@@ -64,7 +64,7 @@ M: alien-invoke-error summary ( error -- )
     ] if ;
 
 M: alien-invoke linearize* ( node -- )
-    compile-gc
+    end-basic-block compile-gc
     dup alien-invoke-parameters objects>registers
     dup alien-invoke-dlsym %alien-invoke ,
     dup linearize-cleanup box-return

library/compiler/intrinsics.factor

@@ -51,6 +51,7 @@ namespaces sequences words ;
             "val" get "obj" get "slot" get %set-slot ,
         ] with-template
     ] if
+    end-basic-block
     T{ vreg f 1 } %write-barrier ,
 ] "intrinsic" set-word-prop
 
@@ -67,7 +68,8 @@ namespaces sequences words ;
 ] "intrinsic" set-word-prop
 
 \ type [
-    { { 0 "in" } } { "in" } [ "in" get %type , ] with-template
+    { { 0 "in" } } { "in" }
+    [ end-basic-block "in" get %type , ] with-template
 ] "intrinsic" set-word-prop
 
 \ tag [
@@ -97,7 +99,7 @@ namespaces sequences words ;
 
 : (binary-op) ( node in -- )
     { "x" } [
-        >r "y" get "x" get dup r> execute ,
+        end-basic-block >r "y" get "x" get dup r> execute ,
     ] with-template ; inline
 
 : binary-op ( node op -- )
@@ -118,7 +120,7 @@ namespaces sequences words ;
 
 : binary-jump ( node label op -- )
     rot dup binary-in { } [
-        >r >r "y" get "x" get r> r> execute ,
+        end-basic-block >r >r "y" get "x" get r> r> execute ,
     ] with-template ; inline
 
 {
@@ -140,6 +142,7 @@ namespaces sequences words ;
     ! hard-coded to put its output in vreg 2, which happends to
     ! be EDX there.
     { { 0 "x" } { 1 "y" } } { "out" } [
+        end-basic-block
         T{ vreg f 2 } "out" set
         "y" get "x" get "out" get %fixnum-mod ,
     ] with-template
@@ -148,6 +151,7 @@ namespaces sequences words ;
 \ fixnum/mod [
     ! See the remark on fixnum-mod for vreg usage
     { { 0 "x" } { 1 "y" } } { "quo" "rem" } [
+        end-basic-block
         T{ vreg f 0 } "quo" set
         T{ vreg f 2 } "rem" set
         "y" get "x" get 2array
@@ -191,6 +195,7 @@ namespaces sequences words ;
     ] if ;
 
 \ fixnum-shift [
+    end-basic-block
     dup literal-immediate? [
         [ node-in-d peek value-literal ] keep fast-shift
     ] [

library/compiler/linearizer.factor

@@ -27,7 +27,7 @@ UNION: #terminal POSTPONE: f #return #values #terminal-merge ;
 GENERIC: linearize* ( node -- next )
 
 : linearize-child ( node -- )
-    [ node@ linearize* ] iterate-nodes ;
+    [ node@ linearize* ] iterate-nodes end-basic-block ;
 
 ! A map from words to linear IR.
 SYMBOL: linearized
@@ -44,9 +44,7 @@ SYMBOL: renamed-labels
 
 : linearize-1 ( word node -- )
     swap [
-        dup stack-reserve %prologue ,
+        dup stack-reserve %prologue , linearize-child
-        linearize-child
-        end-basic-block
     ] make-linear ;
 
 : init-linearizer ( -- )
@@ -61,6 +59,7 @@ SYMBOL: renamed-labels
 M: node linearize* ( node -- next ) drop iterate-next ;
 
 : linearize-call ( label -- next )
+    end-basic-block
     tail-call? [ %jump , f ] [ %call , iterate-next ] if ;
 
 : rename-label ( label -- label )
@@ -86,9 +85,10 @@ M: #label linearize* ( node -- next )
     [ node-param "if-intrinsic" word-prop ] [ drop f ] if ;
 
 : linearize-if ( node label -- next )
-    <label> dup >r >r >r node-children first2 linearize-child
+    <label> [
-    r> r> %jump-label , %label , linearize-child r> %label ,
+        >r >r node-children first2 linearize-child
-    iterate-next ;
+        r> r> %jump-label , %label , linearize-child
+    ] keep %label , iterate-next ;
 
 M: #call linearize* ( node -- next )
     dup if-intrinsic [
@@ -128,17 +128,16 @@ SYMBOL: live-r
 : shuffle-height ( node -- )
     [ dup node-out-d length swap node-in-d length - ] keep
     dup node-out-r length swap node-in-r length -
-    adjust-stacks end-basic-block ;
+    adjust-stacks ;
 
 M: #shuffle linearize* ( #shuffle -- )
-    [
+    0 vreg-allocator set
-        0 vreg-allocator set
+    dup node-in-d over node-out-d live-stores live-d set
-        dup node-in-d over node-out-d live-stores live-d set
+    dup node-in-r over node-out-r live-stores live-r set
-        dup node-in-r over node-out-r live-stores live-r set
+    dup do-inputs
-        dup do-inputs
+    shuffle-height
-        shuffle-height
+    live-d get live-r get template-outputs
-        live-d get live-r get template-outputs
+    iterate-next ;
-    ] with-scope iterate-next ;
 
 : ?static-branch ( node -- n )
     node-in-d first dup value?
@@ -146,10 +145,11 @@ M: #shuffle linearize* ( #shuffle -- )
 
 M: #if linearize* ( node -- next )
     dup ?static-branch [
-        -1 0 adjust-stacks end-basic-block
+        -1 0 adjust-stacks
         swap node-children nth linearize-child iterate-next
     ] [
         dup { { 0 "flag" } } { } [
+            end-basic-block
             <label> dup "flag" get %jump-t ,
         ] with-template linearize-if
     ] if* ;
@@ -157,12 +157,14 @@ M: #if linearize* ( node -- next )
 : dispatch-head ( node -- label/node )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
-    dup { { 0 "n" } } { } [ "n" get %dispatch , ] with-template
+    dup { { 0 "n" } } { }
+    [ end-basic-block "n" get %dispatch , ] with-template
     node-children [ <label> dup %target-label ,  2array ] map ;
 
 : dispatch-body ( label/node -- )
     <label> swap [
-        first2 %label , linearize-child dup %jump-label ,
+        first2 %label , linearize-child end-basic-block
+        dup %jump-label ,
     ] each %label , ;
 
 M: #dispatch linearize* ( node -- next )
@@ -170,4 +172,4 @@ M: #dispatch linearize* ( node -- next )
     #! take in case the top of stack has that type.
     dispatch-head dispatch-body iterate-next ;
 
-M: #return linearize* drop %return , f ;
+M: #return linearize* drop end-basic-block %return , f ;

library/compiler/templates.factor

@@ -11,13 +11,13 @@ SYMBOL: r-height
 TUPLE: ds-loc n ;
 
 C: ds-loc ( n -- ds-loc ) 
-    [ >r d-height get + r> set-ds-loc-n ] keep ;
+    [ >r d-height get - r> set-ds-loc-n ] keep ;
 
 ! A call stack location.
 TUPLE: cs-loc n ;
 
 C: cs-loc ( n -- ds-loc ) 
-    [ >r r-height get + r> set-cs-loc-n ] keep ;
+    [ >r r-height get - r> set-cs-loc-n ] keep ;
 
 : adjust-stacks ( inc-d inc-r -- )
     r-height [ + ] change d-height [ + ] change ;
@@ -95,14 +95,11 @@ SYMBOL: any-reg
 SYMBOL: template-height
 
 : with-template ( node in out quot -- )
-    [
+    pick length pick length swap - template-height set
-        0 vreg-allocator set
+    swap >r >r
-        pick length pick length swap - template-height set
+    >r dup node-in-d r> { } { } template-inputs
-        swap >r >r
+    template-height get 0 adjust-stacks
-        >r dup node-in-d r> { } { } template-inputs
+    node set r> call r> { } template-outputs ; inline
-        template-height get 0 adjust-stacks end-basic-block
-         node set r> call r> { } template-outputs
-    ] with-scope ; inline
 
 : literals/computed ( stack -- literals computed )
     dup [ dup value? [ drop f ] unless ] map

library/compiler/vops.factor

@@ -82,12 +82,6 @@ TUPLE: vop inputs outputs label ;
 : output-operand ( n -- n ) output v>operand ;
 : label ( -- label ) vop get vop-label ;
 
-GENERIC: basic-block? ( vop -- ? )
-M: vop basic-block? drop f ;
-
-! simplifies some code
-M: f basic-block? drop f ;
-
 : make-vop ( inputs outputs label vop -- vop )
     [ >r <vop> r> set-delegate ] keep ;
 
@@ -148,22 +142,18 @@ C: %target-label make-vop ;
 TUPLE: %peek ;
 C: %peek make-vop ;
 : %peek swap src/dest-vop <%peek> ;
-M: %peek basic-block? drop t ;
 
 TUPLE: %replace ;
 C: %replace make-vop ;
 : %replace ( vreg loc -- vop ) src/dest-vop <%replace> ;
-M: %replace basic-block? drop t ;
 
 TUPLE: %inc-d ;
 C: %inc-d make-vop ;
 : %inc-d ( n -- node ) src-vop <%inc-d> ;
-M: %inc-d basic-block? drop t ;
 
 TUPLE: %inc-r ;
 C: %inc-r make-vop ;
 : %inc-r ( n -- ) src-vop <%inc-r> ;
-M: %inc-r basic-block? drop t ;
 
 TUPLE: %immediate ;
 C: %immediate make-vop ;
@@ -171,25 +161,20 @@ C: %immediate make-vop ;
 : %immediate ( obj vreg -- vop )
     src/dest-vop <%immediate> ;
 
-M: %immediate basic-block? drop t ;
-
 ! indirect load of a literal through a table
 TUPLE: %indirect ;
 C: %indirect make-vop ;
 : %indirect ( obj vreg -- )
     src/dest-vop <%indirect> ;
-M: %indirect basic-block? drop t ;
 
 ! object slot accessors
 TUPLE: %untag ;
 C: %untag make-vop ;
 : %untag dest-vop <%untag> ;
-M: %untag basic-block? drop t ;
 
 TUPLE: %slot ;
 C: %slot make-vop ;
 : %slot ( n vreg ) 2-vop <%slot> ;
-M: %slot basic-block? drop t ;
 
 : set-slot-vop
     [ 3array ] keep 1array f ;
@@ -201,28 +186,23 @@ C: %set-slot make-vop ;
     #! %set-slot writes to vreg obj.
     set-slot-vop <%set-slot> ;
 
-M: %set-slot basic-block? drop t ;
-
 ! in the 'fast' versions, the object's type and slot number is
 ! known at compile time, so these become a single instruction
 TUPLE: %fast-slot ;
 C: %fast-slot make-vop ;
 : %fast-slot ( n vreg )
     2-vop <%fast-slot> ;
-M: %fast-slot basic-block? drop t ;
 
 TUPLE: %fast-set-slot ;
 C: %fast-set-slot make-vop ;
 : %fast-set-slot ( value obj n )
     #! %fast-set-slot writes to vreg obj.
     over >r 3array r> 1array f <%fast-set-slot> ;
-M: %fast-set-slot basic-block? drop t ;
 
 ! Char readers and writers
 TUPLE: %char-slot ;
 C: %char-slot make-vop ;
 : %char-slot ( n vreg ) 2-vop <%char-slot> ;
-M: %char-slot basic-block? drop t ;
 
 TUPLE: %set-char-slot ;
 C: %set-char-slot make-vop ;
@@ -231,8 +211,6 @@ C: %set-char-slot make-vop ;
     #! %set-char-slot writes to vreg obj.
     set-slot-vop <%set-char-slot> ;
 
-M: %set-char-slot basic-block? drop t ;
-
 TUPLE: %write-barrier ;
 C: %write-barrier make-vop ;
 : %write-barrier ( ptr ) dest-vop <%write-barrier> ;
@@ -253,19 +231,15 @@ C: %fixnum/mod make-vop ;    : %fixnum/mod f <%fixnum/mod> ;
 
 TUPLE: %fixnum-bitand ;
 C: %fixnum-bitand make-vop ; : %fixnum-bitand 3-vop <%fixnum-bitand> ;
-M: %fixnum-bitand basic-block? drop t ;
 
 TUPLE: %fixnum-bitor ;
 C: %fixnum-bitor make-vop ;  : %fixnum-bitor 3-vop <%fixnum-bitor> ;
-M: %fixnum-bitor basic-block? drop t ;
 
 TUPLE: %fixnum-bitxor ;
 C: %fixnum-bitxor make-vop ; : %fixnum-bitxor 3-vop <%fixnum-bitxor> ;
-M: %fixnum-bitxor basic-block? drop t ;
 
 TUPLE: %fixnum-bitnot ;
 C: %fixnum-bitnot make-vop ; : %fixnum-bitnot 2-vop <%fixnum-bitnot> ;
-M: %fixnum-bitnot basic-block? drop t ;
 
 ! At the VOP level, the 'shift' operation is split into four
 ! distinct operations:
@@ -276,13 +250,11 @@ M: %fixnum-bitnot basic-block? drop t ;
 ! - shifts with a large negative count: %fixnum-sgn
 TUPLE: %fixnum>> ;
 C: %fixnum>> make-vop ;   : %fixnum>>   3-vop <%fixnum>>> ;
-M: %fixnum>> basic-block? drop t ;
 
 ! due to x86 limitations the destination of this VOP must be
 ! vreg 2 (EDX), and the source must be vreg 0 (EAX).
 TUPLE: %fixnum-sgn ;
 C: %fixnum-sgn make-vop ; : %fixnum-sgn src/dest-vop <%fixnum-sgn> ;
-M: %fixnum-sgn basic-block? drop t ;
 
 ! Integer comparison followed by a conditional branch is
 ! optimized
@@ -314,12 +286,10 @@ C: %type make-vop ;
 TUPLE: %tag ;
 C: %tag make-vop ;
 : %tag ( vreg ) dest-vop <%tag> ;
-M: %tag basic-block? drop t ;
 
 TUPLE: %getenv ;
 C: %getenv make-vop ;
 : %getenv src/dest-vop <%getenv> ;
-M: %getenv basic-block? drop t ;
 
 TUPLE: %setenv ;
 C: %setenv make-vop ;