Fixing some bugs, with-template argument order reversed

library/compiler/intrinsics.factor

@@ -6,65 +6,65 @@ inference kernel kernel-internals lists math math-internals
 namespaces sequences words ;
 
 \ slot [
-    H{
+    [
-        { +input { { f "obj" } { f "n" } } }
-        { +output { "obj" } }
-    } [
         "obj" get %untag ,
         "n" get "obj" get %slot ,
-    ] with-template
+    ] H{
+        { +input { { f "obj" } { f "n" } } }
+        { +output { "obj" } }
+    } with-template
 ] "intrinsic" set-word-prop
 
 \ set-slot [
-    H{
+    [
-        { +input { { f "val" } { f "obj" } { f "slot" } } }
-        { +clobber { "obj" } }
-    } [
         "obj" get %untag ,
         "val" get "obj" get "slot" get %set-slot ,
         finalize-contents
         "obj" get %write-barrier ,
-    ] with-template
+    ] H{
+        { +input { { f "val" } { f "obj" } { f "slot" } } }
+        { +clobber { "obj" } }
+    } with-template
 ] "intrinsic" set-word-prop
 
 \ char-slot [
-    H{
+    [
+        "n" get "str" get %char-slot ,
+    ] H{
         { +input { { f "n" } { f "str" } } }
         { +output { "str" } }
-    } [
+    } with-template
-        "n" get "str" get %char-slot ,
-    ] with-template
 ] "intrinsic" set-word-prop
 
 \ set-char-slot [
-    H{
+    [
-        { +input { { f "ch" } { f "n" } { f "str" } } }
-    } [
         "ch" get "str" get "n" get %set-char-slot ,
-    ] with-template
+    ] H{
+        { +input { { f "ch" } { f "n" } { f "str" } } }
+    } with-template
 ] "intrinsic" set-word-prop
 
 \ type [
-    H{
+    [ finalize-contents "in" get %type , ] H{
         { +input { { f "in" } } }
         { +output { "in" } }
-    } [ finalize-contents "in" get %type , ] with-template
+    } with-template
 ] "intrinsic" set-word-prop
 
 \ tag [
-    H{
+    [ "in" get %tag , ] H{
         { +input { { f "in" } } }
         { +output { "in" } }
-    } [ "in" get %tag , ] with-template
+    } with-template
 ] "intrinsic" set-word-prop
 
 : binary-op ( op -- )
-    H{
+    [
+        finalize-contents >r "y" get "x" get dup r> execute ,
+    ] H{
         { +input { { 0 "x" } { 1 "y" } } }
         { +output { "x" } }
-    } [
+    } with-template ; inline
-        finalize-contents >r "y" get "x" get dup r> execute ,
-    ] with-template ; inline
 
 {
     { fixnum+       %fixnum+       }
@@ -77,12 +77,12 @@ namespaces sequences words ;
 ] each
 
 : binary-op-fast ( op -- )
-    H{
+    [
+        >r "y" get "x" get dup r> execute ,
+    ] H{
         { +input { { f "x" } { f "y" } } }
         { +output { "x" } }
-    } [
+    } with-template ; inline
-        >r "y" get "x" get dup r> execute ,
-    ] with-template ; inline
 
 {
     { fixnum-bitand %fixnum-bitand }
@@ -96,11 +96,11 @@ namespaces sequences words ;
 ] each
 
 : binary-jump ( label op -- )
-    H{
+    [
-        { +input { { f "x" } { f "y" } } }
-    } [
         end-basic-block >r >r "y" get "x" get r> r> execute ,
-    ] with-template ; inline
+    ] H{
+        { +input { { f "x" } { f "y" } } }
+    } with-template ; inline
 
 {
     { fixnum<= %jump-fixnum<= }
@@ -117,33 +117,33 @@ 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.
-    H{
+    [
-        { +input { { 0 "x" } { 1 "y" } } }
-        { +output { "out" } }
-    } [
         finalize-contents
         T{ vreg f 2 } "out" set
         "y" get "x" get "out" get %fixnum-mod ,
-    ] with-template
+    ] H{
+        { +input { { 0 "x" } { 1 "y" } } }
+        { +output { "out" } }
+    } with-template
 ] "intrinsic" set-word-prop
 
 \ fixnum/mod [
     ! See the remark on fixnum-mod for vreg usage
-    H{
+    [
-        { +input { { 0 "x" } { 1 "y" } } }
-        { +output { "quo" "rem" } }
-    } [
         finalize-contents
         T{ vreg f 0 } "quo" set
         T{ vreg f 2 } "rem" set
         "y" get "x" get 2array
         "rem" get "quo" get 2array %fixnum/mod ,
-    ] with-template
+    ] H{
+        { +input { { 0 "x" } { 1 "y" } } }
+        { +output { "quo" "rem" } }
+    } with-template
 ] "intrinsic" set-word-prop
 
 \ fixnum-bitnot [
-    H{
+    [ "x" get dup %fixnum-bitnot , ] H{
         { +input { { f "x" } } }
         { +output { "x" } }
-    } [ "x" get dup %fixnum-bitnot , ] with-template
+    } with-template
 ] "intrinsic" set-word-prop

library/compiler/linearizer.factor

@@ -99,19 +99,18 @@ M: #call-label linearize* ( node -- next )
     node-param renamed-label linearize-call ;
 
 M: #if linearize* ( node -- next )
-    H{
+    [
-        { +input { { 0 "flag" } } }
-    } [
         end-basic-block
         <label> dup "flag" get %jump-t ,
-    ] with-template linearize-if ;
+    ] H{
+        { +input { { 0 "flag" } } }
+    } with-template linearize-if ;
 
 : dispatch-head ( node -- label/node )
     #! Output the jump table insn and return a list of
     #! label/branch pairs.
-    H{
+    [ end-basic-block "n" get %dispatch , ]
-        { +input { { 0 "n" } } }
+    H{ { +input { { 0 "n" } } } } with-template
-    } [ end-basic-block "n" get %dispatch , ] with-template
     node-children [ <label> dup %target-label ,  2array ] map ;
 
 : dispatch-body ( label/node -- )

library/compiler/templates.factor

@@ -128,10 +128,8 @@ SYMBOL: phantom-r
 : phantoms ( -- phantom phantom ) phantom-d get phantom-r get ;
 
 : flush-locs ( phantom phantom -- )
-    [
     2dup live-locs \ live-locs set
-        [ dup phantom-locs* [ lazy-store ] 2each ] 2apply
+    [ dup phantom-locs* [ lazy-store ] 2each ] 2apply ;
-    ] with-scope ;
 
 : finalize-contents ( -- )
     phantoms 2dup flush-locs [ vregs>stack ] 2apply ;
@@ -214,8 +212,7 @@ SYMBOL: phantom-r
     over length over adjust-phantom swap nappend ;
 
 : (template-outputs) ( seq stack -- )
-    phantoms swapd phantom-append phantom-append
+    phantoms swapd phantom-append phantom-append ;
-    compute-free-vregs ;
 
 SYMBOL: +input
 SYMBOL: +output
@@ -230,41 +227,34 @@ SYMBOL: +clobber
         { +clobber { } }
     } swap hash-union ;
 
-: adjust-free-vregs ( -- )
+: adjust-free-vregs ( seq -- ) free-vregs [ diff ] change ;
-    used-vregs free-vregs [ diff ] change ;
 
 : output-vregs ( -- seq seq )
-    +output get +clobber get [ [ get ] map ] 2apply ;
+    +output +clobber [ get [ get ] map ] 2apply ;
 
 : outputs-clash? ( -- ? )
     output-vregs append phantoms append
     [ swap member? ] contains-with? ;
 
-: finalize-carefully ( -- )
-    #! If the phantom callstack has datastack locations on it,
-    #! we cannot rearrange the datastack and expect meaningful
-    #! results.
-    phantom-r get [ ds-loc? ] contains? [
-        finalize-contents
-    ] [
-        phantom-d get dup { } flush-locs vregs>stack
-    ] if ;
-
 : slow-input ( template -- )
-    dup empty?
+    dup empty? [ finalize-contents ] unless
-    [ finalize-carefully ] unless
+    outputs-clash? [ finalize-contents ] when
-    outputs-clash?
-    [ finalize-contents ] when
     phantom-d get swap [ stack>vregs ] keep phantom-vregs ;
 
+: input-vregs ( -- seq )
+    +input +scratch [ get [ second get vreg-n ] map ] 2apply
+    append ;
+
 : template-inputs ( -- )
     +input get dup { } additional-vregs# ensure-vregs
-    match-template fast-input adjust-free-vregs slow-input ;
+    match-template fast-input
+    used-vregs adjust-free-vregs
+    slow-input
+    input-vregs adjust-free-vregs ;
 
 : template-outputs ( -- )
     +output get [ get ] map { } (template-outputs) ;
 
-: with-template ( spec quot -- )
+: with-template ( quot spec -- )
-    swap fix-spec
+    fix-spec [ template-inputs call template-outputs ] bind
-    [ template-inputs call template-outputs ] bind
     compute-free-vregs ; inline