compiler.*: Backend implementation of varargs

It is turned off by default. Support for using it coming soon. :)

basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor

@@ -436,13 +436,13 @@ IN: compiler.cfg.alias-analysis.tests
 {
     V{
         T{ ##allot f 0 }
-        T{ ##alien-indirect f { } { } { { 2 double-rep 0 } } { } 0 0 "free" }
+        T{ ##alien-indirect f f { } { } { { 2 double-rep 0 } } { } 0 0 "free" }
         T{ ##set-slot-imm f 2 0 1 0 }
     }
 } [
     V{
         T{ ##allot f 0 }
-        T{ ##alien-indirect f { } { } { { 2 double-rep 0 } } { } 0 0 "free" }
+        T{ ##alien-indirect f f { } { } { { 2 double-rep 0 } } { } 0 0 "free" }
         T{ ##set-slot-imm f 2 0 1 0 }
     } test-alias-analysis
 ] unit-test

basis/compiler/cfg/builder/alien/alien-tests.factor

@@ -61,11 +61,20 @@ cpu x86.64? [
         ] if
         V{ }
     } [
-        void { int float double char } cdecl f "func"
+        void { int float double char } cdecl f f "func"
         alien-invoke-params boa caller-parameters
     ] cfg-unit-test
 ] when
 
+! prepare-caller-return
+${
+    cpu x86.32? { { 1 int-rep EAX } } { { 1 int-rep RAX } } ?
+    cpu x86.32? { { 2 double-rep ST0 } } { { 2 double-rep XMM0 } } ?
+} [
+    T{ alien-invoke-params { return int } } prepare-caller-return
+    T{ alien-invoke-params { return double } } prepare-caller-return
+] cfg-unit-test
+
 ! unbox-parameters
 
 ! unboxing ints is only needed on 32bit archs

basis/compiler/cfg/builder/alien/alien.factor

@@ -51,8 +51,8 @@ IN: compiler.cfg.builder.alien
         (caller-parameters)
     ] with-param-regs ;
 
-: prepare-caller-return ( params -- reg-outputs dead-outputs )
+: prepare-caller-return ( params -- reg-outputs )
-    return>> [ { } ] [ base-type load-return ] if-void { } ;
+    return>> [ { } ] [ base-type load-return ] if-void ;
 
 : caller-stack-frame ( params -- cleanup stack-size )
     [ stack-params get ] dip [ return>> ] [ abi>> ] bi stack-cleanup
@@ -83,15 +83,22 @@ IN: compiler.cfg.builder.alien
         base-type box-return ds-push
     ] if-void ;
 
+: params>alien-insn-params ( params --
+                             varargs? reg-inputs stack-inputs
+                             reg-outputs dead-outputs
+                             cleanup stack-size )
+    {
+        [ varargs?>> ]
+        [ caller-parameters ]
+        [ prepare-caller-return { } ]
+        [ caller-stack-frame ]
+    } cleave ;
+
 M: #alien-invoke emit-node ( block node -- block' )
     params>>
     [
-        {
+        [ params>alien-insn-params ]
-            [ caller-parameters ]
+        [ caller-linkage ] bi
-            [ prepare-caller-return ]
-            [ caller-stack-frame ]
-            [ caller-linkage ]
-        } cleave
         <gc-map> ##alien-invoke,
     ]
     [ caller-return ] bi ;
@@ -100,9 +107,7 @@ M: #alien-indirect emit-node ( block node -- block' )
     params>>
     [
         [ ds-pop ^^unbox-any-c-ptr ] dip
-        [ caller-parameters ]
+        params>alien-insn-params
-        [ prepare-caller-return ]
-        [ caller-stack-frame ] tri
         <gc-map> ##alien-indirect,
     ]
     [ caller-return ] bi ;
@@ -110,12 +115,9 @@ M: #alien-indirect emit-node ( block node -- block' )
 M: #alien-assembly emit-node ( block node -- block' )
     params>>
     [
-        {
+        [ params>alien-insn-params ]
-            [ caller-parameters ]
+        [ quot>> ] bi
-            [ prepare-caller-return ]
+        ##alien-assembly,
-            [ caller-stack-frame ]
-            [ quot>> ]
-        } cleave ##alien-assembly,
     ]
     [ caller-return ] bi ;
 

basis/compiler/cfg/instructions/instructions.factor

@@ -669,14 +669,14 @@ literal: boxer gc-map ;
 ! { vreg rep stack#/reg }
 
 VREG-INSN: ##alien-invoke
-literal: reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size symbols dll gc-map ;
+literal: varargs? reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size symbols dll gc-map ;
 
 VREG-INSN: ##alien-indirect
 use: src/int-rep
-literal: reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size gc-map ;
+literal: varargs? reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size gc-map ;
 
 VREG-INSN: ##alien-assembly
-literal: reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot ;
+literal: varargs? reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot ;
 
 VREG-INSN: ##callback-inputs
 literal: reg-outputs stack-outputs ;

basis/compiler/cfg/liveness/liveness-tests.factor

@@ -278,7 +278,7 @@ V{
     T{ ##unbox f 37 29 "alien_offset" int-rep }
     T{ ##unbox f 38 28 "to_double" double-rep }
     T{ ##unbox f 39 36 "to_cell" int-rep }
-    T{ ##alien-invoke f V{ } V{ { 37 int-rep 0 } { 38 double-rep 4 } { 39 int-rep 12 } } { { 40 int-rep EAX } } { } 0 16 "CFRunLoopRunInMode" f T{ gc-map } }
+    T{ ##alien-invoke f f V{ } V{ { 37 int-rep 0 } { 38 double-rep 4 } { 39 int-rep 12 } } { { 40 int-rep EAX } } { } 0 16 "CFRunLoopRunInMode" f T{ gc-map } }
     T{ ##box f 41 40 "from_signed_cell" int-rep T{ gc-map } }
     T{ ##replace f 41 D: 0 }
     T{ ##branch }

basis/cpu/architecture/architecture.factor

@@ -580,11 +580,21 @@ HOOK: %save-context cpu ( temp1 temp2 -- )
 
 HOOK: %c-invoke cpu ( symbols dll gc-map -- )
 
-HOOK: %alien-invoke cpu ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size symbols dll gc-map -- )
+HOOK: %alien-invoke cpu ( varargs? reg-inputs stack-inputs
+                          reg-outputs dead-outputs
+                          cleanup stack-size
+                          symbols dll gc-map -- )
 
-HOOK: %alien-indirect cpu ( src reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size gc-map -- )
+HOOK: %alien-indirect cpu ( src
+                            varargs? reg-inputs stack-inputs
+                            reg-outputs dead-outputs
+                            cleanup stack-size
+                            gc-map -- )
 
-HOOK: %alien-assembly cpu ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot -- )
+HOOK: %alien-assembly cpu ( varargs? reg-inputs stack-inputs
+                            reg-outputs dead-outputs
+                            cleanup stack-size
+                            quot -- )
 
 HOOK: %callback-inputs cpu ( reg-outputs stack-outputs -- )
 

basis/cpu/ppc/ppc.factor

@@ -450,7 +450,10 @@ M:: ppc %c-invoke ( name dll gc-map -- )
     } case
     rep scratch-reg-class rep vreg %spill ;
 
-:: emit-alien-insn ( reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size quot -- )
+:: emit-alien-insn ( varargs? reg-inputs stack-inputs
+                     reg-outputs dead-outputs
+                     cleanup stack-size
+                     quot -- )
     stack-inputs [ first3 store-stack-param ] each
     reg-inputs [ first3 store-reg-param ] each
     quot call
@@ -458,14 +461,17 @@ M:: ppc %c-invoke ( name dll gc-map -- )
     dead-outputs [ first2 discard-reg-param ] each
     ; inline
 
-M: ppc %alien-invoke ( reg-inputs stack-inputs reg-outputs
+M: ppc %alien-invoke ( varargs? reg-inputs stack-inputs
-                       dead-outputs cleanup stack-size
+                       reg-outputs dead-outputs
+                       cleanup stack-size
                        symbols dll gc-map -- )
     '[ _ _ _ %c-invoke ] emit-alien-insn ;
 
-M:: ppc %alien-indirect ( src reg-inputs stack-inputs
+M:: ppc %alien-indirect ( src
-                          reg-outputs dead-outputs cleanup
+                          varargs? reg-inputs stack-inputs
-                          stack-size gc-map -- )
+                          reg-outputs dead-outputs
+                          cleanup stack-size
+                          gc-map -- )
     reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size [
         has-toc [
             11 src load-param
@@ -479,9 +485,10 @@ M:: ppc %alien-indirect ( src reg-inputs stack-inputs
         gc-map gc-map-here
     ] emit-alien-insn ;
 
-M: ppc %alien-assembly ( reg-inputs stack-inputs reg-outputs
+M: ppc %alien-assembly ( varargs? reg-inputs stack-inputs
-                         dead-outputs cleanup stack-size quot
+                         reg-outputs dead-outputs
-                         -- )
+                         cleanup stack-size
+                         quot -- )
     '[ _ call( -- ) ] emit-alien-insn ;
 
 M: ppc %callback-inputs ( reg-outputs stack-outputs -- )

basis/cpu/x86/x86-tests.factor

@@ -41,7 +41,7 @@ cpu x86.64? [
 ! %alien-invoke
 { 1 } [
     init-relocation init-gc-maps [
-        { } { } { } { } 0 0 { } "dll" T{ gc-map { scrub-d V{ 0 } } } %alien-invoke
+        f { } { } { } { } 0 0 { } "dll" T{ gc-map { scrub-d V{ 0 } } } %alien-invoke
     ] B{ } make drop
     gc-maps get length
 ] unit-test

basis/cpu/x86/x86.factor

@@ -649,32 +649,32 @@ HOOK: %prepare-var-args cpu ( reg-inputs -- )
 
 HOOK: %cleanup cpu ( n -- )
 
-M:: x86 %alien-assembly ( reg-inputs
+M:: x86 %alien-assembly ( varargs? reg-inputs stack-inputs
-                          stack-inputs
+                          reg-outputs dead-outputs
-                          reg-outputs
+                          cleanup stack-size
-                          dead-outputs
-                          cleanup
-                          stack-size
                           quot -- )
     stack-inputs [ first3 %store-stack-param ] each
-    reg-inputs [ [ first3 %store-reg-param ] each ] [ %prepare-var-args ] bi
+    reg-inputs [ first3 %store-reg-param ] each
+    varargs? [ reg-inputs %prepare-var-args ] when
     quot call( -- )
     cleanup %cleanup
     reg-outputs [ first3 %load-reg-param ] each
     dead-outputs [ first2 %discard-reg-param ] each ;
 
-M: x86 %alien-invoke ( reg-inputs stack-inputs
+M: x86 %alien-invoke ( varargs? reg-inputs stack-inputs
                        reg-outputs dead-outputs
-                       cleanup
+                       cleanup stack-size
-                       stack-size
                        symbols dll gc-map -- )
-                       '[ _ _ _ %c-invoke ] %alien-assembly ;
+    '[ _ _ _ %c-invoke ] %alien-assembly ;
 
 M:: x86 %alien-indirect ( src
-                          reg-inputs stack-inputs
+                          varargs? reg-inputs stack-inputs
                           reg-outputs dead-outputs
-                          cleanup stack-size gc-map -- )
+                          cleanup stack-size
-    reg-inputs stack-inputs reg-outputs dead-outputs cleanup stack-size [
+                          gc-map -- )
+    varargs? reg-inputs stack-inputs
+    reg-outputs dead-outputs
+    cleanup stack-size [
         src ?spill-slot CALL
         gc-map gc-map-here
     ] %alien-assembly ;

basis/stack-checker/alien/alien-tests.factor

@@ -53,6 +53,6 @@ ${
         ] do-callback
     ] ?
 } [
-    int { int int } cdecl alien-node-params boa
+    int { int int } cdecl f alien-node-params boa
     [ "hello" ] wrap-callback-quot
 ] unit-test

basis/stack-checker/alien/alien.factor

@@ -8,7 +8,9 @@ stack-checker.visitor strings words ;
 FROM: kernel.private => declare ;
 IN: stack-checker.alien
 
-TUPLE: alien-node-params return parameters { abi abi initial: cdecl } ;
+TUPLE: alien-node-params
+    return parameters
+    { abi abi initial: cdecl } varargs? ;
 
 TUPLE: alien-invoke-params < alien-node-params
     library