Temporary fixes for x86-32 until FFI boxing is rewritten

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

@@ -64,8 +64,7 @@ M:: struct-c-type unbox-parameter ( src c-type -- )
     ] when ;
 
 : (objects>registers) ( vregs -- )
-    ! Place instructions in reverse order, so that the
-    ! ##store-stack-param instructions come first. This ensures
+    ! Place ##store-stack-param instructions first. This ensures
     ! that no registers are used after the ##store-reg-param
     ! instructions.
     [
@@ -73,7 +72,7 @@ M:: struct-c-type unbox-parameter ( src c-type -- )
         [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]
         [ [ next-reg-param ] keep \ ##store-reg-param new-insn ]
         if
-    ] map reverse % ;
+    ] map [ ##store-stack-param? ] partition [ % ] bi@ ;
 
 : objects>registers ( params -- stack-size )
     [ abi>> ] [ parameters>> ] [ return>> ] tri
@@ -230,8 +229,20 @@ GENERIC: flatten-c-type ( type -- reps )
 
 M: struct-c-type flatten-c-type
     flatten-struct-type [ first2 [ drop stack-params ] when ] map ;
+    
 M: long-long-type flatten-c-type drop { int-rep int-rep } ;
-M: c-type flatten-c-type rep>> 1array ;
+
+M: c-type flatten-c-type
+    rep>> {
+        { int-rep [ { int-rep } ] }
+        { float-rep [ float-on-stack? { stack-params } { float-rep } ? ] }
+        { double-rep [
+            float-on-stack?
+            cell 4 = { stack-params stack-params } { stack-params } ?
+            { double-rep } ?
+        ] }
+    } case ;
+    
 M: object flatten-c-type base-type flatten-c-type ;
 
 : flatten-c-types ( types -- reps )

basis/cpu/architecture/architecture.factor

@@ -552,6 +552,9 @@ HOOK: dummy-fp-params? cpu ( -- ? )
 ! If t, long longs are never passed in param regs
 HOOK: long-long-on-stack? cpu ( -- ? )
 
+! If t, floats are never passed in param regs
+HOOK: float-on-stack? cpu ( -- ? )
+
 ! If t, the struct return pointer is never passed in a param reg
 HOOK: struct-return-on-stack? cpu ( -- ? )
 

basis/cpu/x86/32/32.factor

@@ -7,6 +7,7 @@ command-line make words compiler compiler.units
 compiler.constants compiler.alien compiler.codegen
 compiler.codegen.fixup compiler.cfg.instructions
 compiler.cfg.builder compiler.cfg.builder.alien
+compiler.cfg.builder.alien.params
 compiler.cfg.intrinsics compiler.cfg.stack-frame
 cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
 cpu.architecture vm ;
@@ -116,11 +117,37 @@ M: stack-params store-return-reg drop EAX MOV ;
 M: int-rep load-return-reg drop EAX swap MOV ;
 M: int-rep store-return-reg drop EAX MOV ;
 
-M: float-rep load-return-reg drop FLDS ;
-M: float-rep store-return-reg drop FSTPS ;
+:: load-float-return ( src x87-insn sse-insn -- )
+    src register? [
+        ESP 4 SUB
+        ESP [] src sse-insn execute
+        ESP [] x87-insn execute
+        ESP 4 ADD
+    ] [
+        src x87-insn execute
+    ] if ; inline
 
-M: double-rep load-return-reg drop FLDL ;
-M: double-rep store-return-reg drop FSTPL ;
+:: store-float-return ( dst x87-insn sse-insn -- )
+    dst register? [
+        ESP 4 SUB
+        ESP [] x87-insn execute
+        dst ESP [] sse-insn execute
+        ESP 4 ADD
+    ] [
+        dst x87-insn execute
+    ] if ; inline
+
+M: float-rep load-return-reg
+    drop \ FLDS \ MOVSS load-float-return ;
+
+M: float-rep store-return-reg
+    drop \ FSTPS \ MOVSS store-float-return ;
+
+M: double-rep load-return-reg
+    drop \ FLDL \ MOVSD load-float-return ;
+
+M: double-rep store-return-reg
+    drop \ FSTPL \ MOVSD store-float-return ;
 
 M: x86.32 %prologue ( n -- )
     dup PUSH
@@ -138,9 +165,12 @@ M: x86.32 %prepare-jump
 
 M:: x86.32 %unbox ( dst src func rep -- )
     src func call-unbox-func
-    dst rep reg-class-of return-reg rep %copy ;
+    dst ?spill-slot rep store-return-reg ;
 
-M:: x86.32 %store-long-long-return ( src1 src2 n func -- )
+M:: x86.32 %store-return ( src rep -- )
+    src ?spill-slot rep load-return-reg ;
+
+M:: x86.32 %store-long-long-return ( src1 src2 -- )
     src2 EAX = [ src1 src2 XCHG src2 src1 ] [ src1 src2 ] if :> ( src1 src2 )
     EAX src1 int-rep %copy
     EDX src2 int-rep %copy ;
@@ -256,9 +286,9 @@ M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
     bi and ;
 
 : stack-arg-size ( params -- n )
-    dup abi>> '[
+    dup abi>> [
         alien-parameters flatten-c-types
-        [ _ alloc-parameter 2drop ] each
+        [ alloc-parameter 2drop ] each
         stack-params get
     ] with-param-regs ;
 
@@ -289,7 +319,10 @@ M: x86.32 dummy-fp-params? f ;
 
 M: x86.32 long-long-on-stack? t ;
 
-M: x86.32 structs-on-stack? t ;
+M: x86.32 float-on-stack? t ;
+
+M: x86.32 flatten-struct-type
+    stack-size cell /i { int-rep t } <repetition> ;
 
 M: x86.32 struct-return-on-stack? os linux? not ;
 

basis/cpu/x86/64/64.factor

@@ -124,6 +124,9 @@ M:: x86.64 %unbox ( dst src func rep -- )
         { float-regs [ float-regs get pop swap MOVSD ] }
     } case ;
 
+M:: x86.64 %store-return ( src rep -- )
+    rep reg-class-of return-reg src rep %copy ;
+
 M:: x86.64 %store-struct-return ( src c-type -- )
     ! Move src to R11 so that we don't clobber it.
     R11 src int-rep %copy
@@ -220,6 +223,8 @@ M:: x86.64 %call-gc ( gc-roots -- )
 
 M: x86.64 long-long-on-stack? f ;
 
+M: x86.64 float-on-stack? f ;
+
 M: x86.64 struct-return-on-stack? f ;
 
 ! The result of reading 4 bytes from memory is a fixnum on

basis/cpu/x86/x86.factor

@@ -1458,9 +1458,6 @@ M:: x86 %store-reg-param ( src reg rep -- )
 M:: x86 %store-stack-param ( src n rep -- )
     n param@ src rep %copy ;
 
-M:: x86 %store-return ( src rep -- )
-    rep reg-class-of return-reg src rep %copy ;
-
 HOOK: struct-return@ cpu ( n -- operand )
 
 M: x86 %prepare-struct-area ( dst -- )