Fix find-template regression: many intrinsics were not open-coded on x86

core/compiler/test/templates-early.factor

@@ -187,3 +187,30 @@ SYMBOL: template-chosen
     ! This should not fail
     [ ] [ [ end-basic-block ] { } make drop ] unit-test
 ] with-scope
+
+! Regression
+SYMBOL: templates-chosen
+
+V{ } clone templates-chosen set
+
+: template-choice-1 ;
+
+\ template-choice-1
+[ "template-choice-1" templates-chosen get push ]
+H{
+    { +input+ { { f "obj" } { [ ] "n" } } }
+    { +output+ { "obj" } }
+} define-intrinsic
+
+: template-choice-2 ;
+
+\ template-choice-2
+[ "template-choice-2" templates-chosen get push drop ]
+{ { f "x" } { f "y" } } define-if-intrinsic
+
+[ ] [
+    [ 2 template-choice-1 template-choice-2 ] compile-quot drop
+] unit-test
+
+[ V{ "template-choice-1" "template-choice-2" } ]
+[ templates-chosen get ] unit-test

core/cpu/x86/intrinsics/intrinsics.factor

@@ -586,7 +586,7 @@ IN: cpu.x86.intrinsics
     "value" operand [ swap MOV ] %alien-accessor
 ] H{
     { +input+ {
-        { unboxed-c-ptr "value" c-ptr }
+        { unboxed-c-ptr "value" pinned-c-ptr }
         { unboxed-c-ptr "alien" c-ptr }
         { f "offset" fixnum }
     } }

core/generator/registers/registers.factor

@@ -459,13 +459,22 @@ M: loc lazy-store
     ] each-loc ;
 
 : reset-phantom ( phantom -- )
-    dup phantom-locs* over delete-all swap push-all ;
+    #! Kill register assignments but preserve constants and
+    #! class information.
+    dup phantom-locs*
+    over [
+        dup constant? [ nip ] [
+            operand-class over set-operand-class
+        ] if
+    ] 2map
+    over delete-all
+    swap push-all ;
 
 : reset-phantoms ( -- )
     [ reset-phantom ] each-phantom ;
 
 : finalize-contents ( -- )
-    finalize-locs finalize-vregs [ delete-all ] each-phantom ;
+    finalize-locs finalize-vregs reset-phantoms ;
 
 : %gc ( -- )
     0 frame-required
@@ -474,8 +483,8 @@ M: loc lazy-store
 
 ! Loading stacks to vregs
 : free-vregs? ( int# float# -- ? )
-    T{ float-regs f 8 } free-vregs length <
-    >r T{ int-regs } free-vregs length < r> and ;
+    T{ float-regs f 8 } free-vregs length <=
+    >r T{ int-regs } free-vregs length <= r> and ;
 
 : phantom&spec ( phantom spec -- phantom' spec' )
     [ length f pad-left ] keep
@@ -591,24 +600,18 @@ M: loc lazy-store
     2dup first value-matches?
     >r >r operand-class 2 r> ?nth class-matches? r> and ;
 
-: template-specs-match? ( -- ? )
-    phantom-d get +input+ get
-    [ spec-matches? ] phantom&spec-agree? ;
-
 : template-matches? ( spec -- ? )
-    clone [
-        template-specs-match?
-        [ guess-template-vregs free-vregs? ] [ f ] if
-    ] bind ;
-
-: (find-template) ( templates -- pair/f )
-    [ second template-matches? ] find nip ;
+    phantom-d get +input+ rot at
+    [ spec-matches? ] phantom&spec-agree? ;
 
 : ensure-template-vregs ( -- )
     guess-template-vregs free-vregs? [
         finalize-contents compute-free-vregs
     ] unless ;
 
+: clear-phantoms ( -- )
+    [ delete-all ] each-phantom ;
+
 PRIVATE>
 
 : set-operand-classes ( classes -- )
@@ -620,15 +623,11 @@ PRIVATE>
     #! Commit all deferred stacking shuffling, and ensure the
     #! in-memory data and retain stacks are up to date with
     #! respect to the compiler's current picture.
-    finalize-contents finalize-heights
+    finalize-contents
+    clear-phantoms
+    finalize-heights
     fresh-objects get dup empty? swap delete-all [ %gc ] unless ;
 
-: do-template ( pair -- )
-    #! Use with return value from find-template
-    first2
-    clone [ template-inputs call template-outputs ] bind
-    compute-free-vregs ; inline
-
 : with-template ( quot hash -- )
     clone [
         ensure-template-vregs
@@ -636,6 +635,10 @@ PRIVATE>
     ] bind
     compute-free-vregs ; inline
 
+: do-template ( pair -- )
+    #! Use with return value from find-template
+    first2 with-template ;
+
 : fresh-object ( obj -- ) fresh-objects get push ;
 
 : fresh-object? ( obj -- ? ) fresh-objects get memq? ;
@@ -657,10 +660,7 @@ PRIVATE>
 
 : find-template ( templates -- pair/f )
     #! Pair has shape { quot hash }
-    compute-free-vregs
-    dup (find-template) [ ] [
-        finalize-contents (find-template)
-    ] ?if ;
+    [ second template-matches? ] find nip ;
 
 : operand-tag ( operand -- tag/f )
     operand-class class-tag ;