Change how we do if-intrinsics

TODO.FACTOR.txt

@@ -15,6 +15,7 @@
 - fdasfsdfsa :help -- weird
 - %allot-bignum-signed-2 still has issues on ppc
 - fix %allot-bignum-signed-1/2 on x86
+- see if 0 0 >= is optimized
 
 + ui:
 

library/compiler/generator/generator.factor

@@ -56,14 +56,16 @@ UNION: #terminal
         relocation-table get
         literal-table get
         word-table get
-    ] V{ } make
+    ] V{ } make code-format add-compiled-block save-xt ;
-    code-format add-compiled-block save-xt ;
+
-! 
 GENERIC: generate-node ( node -- )
 
 : generate-nodes ( node -- )
     [ node@ generate-node ] iterate-nodes end-basic-block ;
 
+: generate-branch ( node -- )
+    [ generate-nodes ] keep-templates ;
+
 : generate ( word node -- )
     [ [ generate-nodes ] with-node-iterator ] generate-1 ;
 
@@ -85,44 +87,57 @@ M: #label generate-node
 
 : generate-if ( node label -- next )
     <label> [
-        >r >r node-children first2 generate-nodes
+        >r >r node-children first2 generate-branch
-        r> r> end-false-branch resolve-label generate-nodes
+        r> r> end-false-branch resolve-label
+        generate-branch
+        init-templates
     ] keep resolve-label iterate-next ;
 
 M: #if generate-node
-    [
+    [ <label> dup %jump-t ]
-        end-basic-block
+    H{ { +input+ { { f "flag" } } } }
-        <label> dup %jump-t
+    with-template
-    ] H{
+    generate-if ;
-        { +input+ { { f "flag" } } }
-    } with-template generate-if ;
 
 ! #call
 : [with-template] ( quot template -- quot )
-    2array >quotation [ with-template ] append ;
+    \ with-template 3array >quotation ;
 
 : define-intrinsic ( word quot template -- )
     [with-template] "intrinsic" set-word-prop ;
 
-: define-if-intrinsic ( word quot template -- )
+: define-if>branch-intrinsic ( word quot inputs -- )
+    +input+ associate
     [with-template] "if-intrinsic" set-word-prop ;
 
-: if>boolean-intrinsic ( label -- )
+: if>boolean-intrinsic ( quot -- )
+    "true" define-label
     "end" define-label
-    f 0 <int-vreg> load-literal
+    "true" get swap call
+    f "if-scratch" get load-literal
     "end" get %jump-label
-    resolve-label
+    "true" resolve-label
-    t 0 <int-vreg> load-literal
+    t "if-scratch" get load-literal
     "end" resolve-label
-    0 <int-vreg> phantom-d get phantom-push
+    "if-scratch" get phantom-d get phantom-push
-    compute-free-vregs ;
+    compute-free-vregs ; inline
+
+: define-if>boolean-intrinsic ( word quot inputs -- )
+    +input+ associate
+    { { f "if-scratch" } } +scratch+ associate
+    hash-union
+    >r [ if>boolean-intrinsic ] curry r>
+    [with-template] "intrinsic" set-word-prop ;
+
+: define-if-intrinsic ( word quot inputs -- )
+    3dup define-if>branch-intrinsic define-if>boolean-intrinsic ;
 
 : do-if-intrinsic ( node -- next )
-    [ <label> dup ] keep if-intrinsic call
+    dup node-successor dup #if? [
-    >r node-successor dup #if? [
+        <label> [ rot if-intrinsic call ] keep
-        r> generate-if node-successor
+        generate-if node-successor
     ] [
-        drop r> if>boolean-intrinsic iterate-next
+        drop intrinsic call iterate-next
     ] if ;
 
 M: #call generate-node
@@ -148,7 +163,7 @@ M: #call-label generate-node
 
 : dispatch-body ( label/node -- )
     <label> swap [
-        first2 resolve-label generate-nodes end-basic-block
+        first2 resolve-label generate-nodes
         dup %jump-label
     ] each resolve-label ;
 

library/compiler/generator/templates.factor

@@ -95,10 +95,6 @@ SYMBOL: phantom-r
 
 : phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
 
-: init-templates ( -- )
-    <phantom-datastack> phantom-d set
-    <phantom-callstack> phantom-r set ;
-
 : finalize-heights ( -- )
     phantoms [ finalize-height ] 2apply ;
 
@@ -149,6 +145,19 @@ SYMBOL: phantom-r
     [ 2dup (compute-free-vregs) ] map>hash \ free-vregs set
     drop ;
 
+: init-templates ( -- )
+    <phantom-datastack> phantom-d set
+    <phantom-callstack> phantom-r set
+    compute-free-vregs ;
+
+: keep-templates ( quot -- )
+    [
+        phantom-d [ clone ] change
+        phantom-r [ clone ] change
+        compute-free-vregs
+        call
+    ] with-scope ; inline
+
 : additional-vregs ( seq seq -- n )
     2array phantoms 2array [ [ length ] map ] 2apply v-
     [ 0 max ] map sum ;

library/compiler/pentium4/intrinsics.factor

@@ -13,7 +13,7 @@ M: float-regs (%replace) drop swap %allot-float ;
 
 ! Floats
 : define-float-op ( word op -- )
-    [ [ "x" operand "y" operand ] % , ] [ ] make H{
+    [ "x" operand "y" operand ] swap add H{
         { +input+ { { float "x" } { float "y" } } }
         { +output+ { "x" } }
     } define-intrinsic ;
@@ -28,11 +28,8 @@ M: float-regs (%replace) drop swap %allot-float ;
 ] each
 
 : define-float-jump ( word op -- )
-    [
+    [ "x" operand "y" operand UCOMISD ] swap add
-        [ end-basic-block "x" operand "y" operand UCOMISD ] % ,
+    { { float "x" } { float "y" } } define-if-intrinsic ;
-    ] [ ] make H{
-        { +input+ { { float "x" } { float "y" } } }
-    } define-if-intrinsic ;
 
 {
     { float< JB }

library/compiler/ppc/intrinsics.factor

@@ -106,10 +106,8 @@ math-internals namespaces sequences words ;
 } define-intrinsic
 
 : define-fixnum-jump ( word op -- )
-    [
+    [ "x" operand 0 "y" operand CMP ] swap add
-        [ end-basic-block "x" operand 0 "y" operand CMP ] % ,
+    { { f "x" } { f "y" } } define-if-intrinsic ;
-     ] [ ] make H{ { +input+ { { f "x" } { f "y" } } } }
-    define-if-intrinsic ;
 
 {
     { fixnum< BLT }
@@ -270,10 +268,8 @@ math-internals namespaces sequences words ;
 ] each
 
 : define-float-jump ( word op -- )
-    [
+    [ "x" operand 0 "y" operand FCMPU ] swap add
-        [ end-basic-block "x" operand 0 "y" operand FCMPU ] % ,
+    { { float "x" } { float "y" } } define-if-intrinsic ;
-     ] [ ] make H{ { +input+ { { float "x" } { float "y" } } } }
-    define-if-intrinsic ;
 
 {
     { float< BLT }

library/compiler/x86/intrinsics.factor

@@ -233,8 +233,8 @@ IN: compiler
 } define-intrinsic
 
 : define-fixnum-jump ( word op -- )
-    [ end-basic-block "x" operand "y" operand CMP ] swap add
+    [ "x" operand "y" operand CMP ] swap add
-    H{ { +input+ { { f "x" } { f "y" } } } } define-if-intrinsic ;
+    { { f "x" } { f "y" } } define-if-intrinsic ;
 
 {
     { fixnum< JL }