New, very hairy with-template specifier style

diff --git a/library/compiler/intrinsics.factor b/library/compiler/intrinsics.factor
index 4958718f81d22609813f1300f18a1d43c7408dc8..606bd61669f5182048098310f56b052d95947046 100644 (file)
--- a/library/compiler/intrinsics.factor
+++ b/library/compiler/intrinsics.factor
@@ -6,15 +6,20 @@ inference kernel kernel-internals lists math math-internals
 namespaces sequences words ;
 
 \ slot [
-    { { any-reg "obj" } { any-reg "n" } } { "obj" } [
+    H{
+        { +input-d { { f "obj" } { f "n" } } }
+        { +output-d { "obj" } }
+    } [
         "obj" get %untag ,
         "n" get "obj" get %slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ set-slot [
-    { { any-reg "val" } { any-reg "obj" } { any-reg "slot" } }
-    { } [
+    H{
+        { +input-d { { f "val" } { f "obj" } { f "slot" } } }
+        { +clobber { "obj" } }
+    } [
         "obj" get %untag ,
         "val" get "obj" get "slot" get %set-slot ,
         finalize-contents
@@ -23,29 +28,41 @@ namespaces sequences words ;
 ] "intrinsic" set-word-prop
 
 \ char-slot [
-    { { any-reg "n" } { any-reg "str" } } { "str" } [
+    H{
+        { +input-d { { f "n" } { f "str" } } }
+        { +output-d { "str" } }
+    } [
         "n" get "str" get %char-slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ set-char-slot [
-    { { any-reg "ch" } { any-reg "n" } { any-reg "str" } } { } [
+    H{
+        { +input-d { { f "ch" } { f "n" } { f "str" } } }
+    } [
         "ch" get "str" get "n" get %set-char-slot ,
     ] with-template
 ] "intrinsic" set-word-prop
 
 \ type [
-    { { any-reg "in" } } { "in" }
-    [ finalize-contents "in" get %type , ] with-template
+    H{
+        { +input-d { { f "in" } } }
+        { +output-d { "in" } }
+    } [ finalize-contents "in" get %type , ] with-template
 ] "intrinsic" set-word-prop
 
 \ tag [
-    { { any-reg "in" } } { "in" }
-    [ "in" get %tag , ] with-template
+    H{
+        { +input-d { { f "in" } } }
+        { +output-d { "in" } }
+    } [ "in" get %tag , ] with-template
 ] "intrinsic" set-word-prop
 
 : binary-op ( op -- )
-    { { 0 "x" } { 1 "y" } } { "x" } [
+    H{
+        { +input-d { { 0 "x" } { 1 "y" } } }
+        { +output-d { "x" } }
+    } [
         finalize-contents >r "y" get "x" get dup r> execute ,
     ] with-template ; inline
 
@@ -63,7 +80,9 @@ namespaces sequences words ;
 ] each
 
 : binary-jump ( label op -- )
-    { { any-reg "x" } { any-reg "y" } } { } [
+    H{
+        { +input-d { { f "x" } { f "y" } } }
+    } [
         end-basic-block >r >r "y" get "x" get r> r> execute ,
     ] with-template ; inline
 
@@ -82,7 +101,10 @@ namespaces sequences words ;
     ! This is not clever. Because of x86, %fixnum-mod is
     ! hard-coded to put its output in vreg 2, which happends to
     ! be EDX there.
-    { { 0 "x" } { 1 "y" } } { "out" } [
+    H{
+        { +input-d { { 0 "x" } { 1 "y" } } }
+        { +output-d { "out" } }
+    } [
         finalize-contents
         T{ vreg f 2 } "out" set
         "y" get "x" get "out" get %fixnum-mod ,
@@ -91,7 +113,10 @@ namespaces sequences words ;
 
 \ fixnum/mod [
     ! See the remark on fixnum-mod for vreg usage
-    { { 0 "x" } { 1 "y" } } { "quo" "rem" } [
+    H{
+        { +input-d { { 0 "x" } { 1 "y" } } }
+        { +output-d { "quo" "rem" } }
+    } [
         finalize-contents
         T{ vreg f 0 } "quo" set
         T{ vreg f 2 } "rem" set
@@ -101,7 +126,8 @@ namespaces sequences words ;
 ] "intrinsic" set-word-prop
 
 \ fixnum-bitnot [
-    { { any-reg "x" } } { "x" } [
-        "x" get dup %fixnum-bitnot ,
-    ] with-template
+    H{
+        { +input-d { { f "x" } } }
+        { +output-d { "x" } }
+    } [ "x" get dup %fixnum-bitnot , ] with-template
 ] "intrinsic" set-word-prop

diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 5d80252c1865d6fea66a7d4b088916a72d4b90d7..d7d2981b8ba51f843ec1fecd9fada404816d687a 100644 (file)
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -99,7 +99,9 @@ M: #call-label linearize* ( node -- next )
     node-param renamed-label linearize-call ;
 
 M: #if linearize* ( node -- next )
-    { { 0 "flag" } } { } [
+    H{
+        { +input-d { { 0 "flag" } } }
+    } [
         end-basic-block
         <label> dup "flag" get %jump-t ,
     ] with-template linearize-if ;
@@ -107,8 +109,9 @@ M: #if linearize* ( node -- next )
 : dispatch-head ( node -- label/node )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
-    { { 0 "n" } } { }
-    [ end-basic-block "n" get %dispatch , ] with-template
+    H{
+        { +input-d { { 0 "n" } } }
+    } [ end-basic-block "n" get %dispatch , ] with-template
     node-children [ <label> dup %target-label ,  2array ] map ;
 
 : dispatch-body ( label/node -- )

diff --git a/library/compiler/templates.factor b/library/compiler/templates.factor
index 6f6aff7c444874f44356e34bb6372ed5e1beead0..3969dbd2abfe5ce0485cb0750ec38379fd2fc431 100644 (file)
--- a/library/compiler/templates.factor
+++ b/library/compiler/templates.factor
@@ -141,8 +141,6 @@ SYMBOL: phantom-r
 : end-basic-block ( -- )
     finalize-contents finalize-heights ;
 
-SYMBOL: any-reg
-
 : used-vregs ( -- seq )
     phantoms append [ vreg? ] subset [ vreg-n ] map ;
 
@@ -151,13 +149,13 @@ SYMBOL: any-reg
     >vector free-vregs set ;
 
 : requested-vregs ( template -- n )
-    [ any-reg eq? ] subset length ;
+    0 [ [ 1+ ] unless ] reduce ;
 
 : template-vreg# ( template template -- n )
     [ requested-vregs ] 2apply + ;
 
 : alloc-regs ( template -- template )
-    [ dup any-reg eq? [ drop alloc-reg ] when ] map ;
+    [ [ alloc-reg ] unless* ] map ;
 
 : alloc-reg# ( n -- regs )
     free-vregs [ cut ] change ;
@@ -190,11 +188,9 @@ SYMBOL: any-reg
 
 : compatible-values? ( value template -- ? )
     {
-        { [ over ds-loc? ] [ 2drop t ] }
-        { [ over cs-loc? ] [ 2drop t ] }
+        { [ over loc? ] [ 2drop t ] }
         { [ dup not ] [ 2drop t ] }
         { [ over not ] [ 2drop f ] }
-        { [ dup any-reg eq? ] [ 2drop t ] }
         { [ dup integer? ] [ swap vreg-n = ] }
     } cond ;
 
@@ -223,35 +219,62 @@ SYMBOL: any-reg
     swap phantom-vregs ;
 
 : fast-input ( template template -- )
-    phantom-r get (fast-input)
-    phantom-d get (fast-input) ;
+    phantoms swapd (fast-input) (fast-input) ;
 
 : (slow-input) ( template phantom -- )
     swap [ stack>vregs ] keep phantom-vregs ;
 
-: slow-input ( template template -- )
-    phantom-r get (slow-input)
-    phantom-d get (slow-input) ;
+: phantom-append ( seq stack -- )
+    over length over adjust-phantom swap nappend ;
+
+: (template-outputs) ( seq stack -- )
+    phantoms swapd phantom-append phantom-append ;
+
+SYMBOL: +input-d
+SYMBOL: +input-r
+SYMBOL: +output-d
+SYMBOL: +output-r
+SYMBOL: +scratch
+SYMBOL: +clobber
+
+: fix-spec ( spec -- spec )
+    H{
+        { +input-d { } }
+        { +input-r { } }
+        { +output-d { } }
+        { +output-r { } }
+        { +scratch { } }
+        { +clobber { } }
+    } swap hash-union ;
 
 : adjust-free-vregs ( -- )
     used-vregs free-vregs [ diff ] change ;
 
-: template-inputs ( template template -- )
+: output-vregs ( -- seq )
+    { +output-d +output-r +clobber }
+    [ get [ get ] map ] map concat ;
+
+: finalize-contents? ( -- ? )
+    output-vregs phantoms append
+    [ swap member? ] contains-with? ;
+
+: slow-input ( template template -- )
+    2dup [ empty? not ] 2apply or finalize-contents? or
+    [ finalize-contents ] when
+    phantoms swapd (slow-input) (slow-input) ;
+
+: template-inputs ( -- )
+    +input-d get +input-r get
     2dup additional-vregs# ensure-vregs
     match-templates fast-input
     adjust-free-vregs
-    finalize-contents
     slow-input ;
 
-: phantom-append ( seq stack -- )
-    over length over adjust-phantom swap nappend ;
-
-: (template-outputs) ( seq stack -- )
-    phantom-r get phantom-append phantom-d get phantom-append ;
-
-: template-outputs ( stack stack -- )
-    [ [ get ] map ] 2apply (template-outputs) ;
+: template-outputs ( -- )
+    +output-d get +output-r get [ [ get ] map ] 2apply
+    (template-outputs) ;
 
-: with-template ( in out quot -- )
-    swap >r >r { } template-inputs
-    r> call r> { } template-outputs ; inline
+: with-template ( spec quot -- )
+    swap fix-spec [
+        template-inputs call template-outputs
+    ] bind ; inline

diff --git a/library/compiler/vops.factor b/library/compiler/vops.factor
index 83a77e36fd23442e8937791082b09a110e9905f8..d65a85bb10d17984fe44ab495d970ac919babf83 100644 (file)
--- a/library/compiler/vops.factor
+++ b/library/compiler/vops.factor
@@ -106,9 +106,6 @@ TUPLE: %label ;
 C: %label make-vop ;
 : %label label-vop <%label> ;
 
-! Return vops take a label that is ignored, to have the
-! same stack effect as jumps. This is needed for the
-! simplifier.
 TUPLE: %return ;
 C: %return make-vop ;
 : %return empty-vop <%return> ;