compiler, cpu.x86.32: clean up FFI implementation, in particular 32-bit x86-specific backend

basis/alien/remote-control/remote-control.factor

@@ -1,18 +1,19 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.data alien.strings parser
+USING: accessors alien alien.c-types alien.data alien.strings
-threads words kernel.private kernel io.encodings.utf8 eval ;
+parser threads words kernel.private kernel io.encodings.utf8
+eval ;
 IN: alien.remote-control
 
 : eval-callback ( -- callback )
-    "void*" { "char*" } "cdecl"
+    void* { char* } "cdecl"
     [ eval>string utf8 malloc-string ] alien-callback ;
 
 : yield-callback ( -- callback )
-    "void" { } "cdecl" [ yield ] alien-callback ;
+    void { } "cdecl" [ yield ] alien-callback ;
 
 : sleep-callback ( -- callback )
-    "void" { "long" } "cdecl" [ sleep ] alien-callback ;
+    void { long } "cdecl" [ sleep ] alien-callback ;
 
 : ?callback ( word -- alien )
     dup optimized? [ execute ] [ drop f ] if ; inline

basis/compiler/alien/alien.factor

@@ -9,10 +9,10 @@ IN: compiler.alien
 
 : alien-parameters ( params -- seq )
     dup parameters>>
-    swap return>> large-struct? [ "void*" prefix ] when ;
+    swap return>> large-struct? [ void* prefix ] when ;
 
 : alien-return ( params -- ctype )
-    return>> dup large-struct? [ drop "void" ] when ;
+    return>> dup large-struct? [ drop void ] when ;
 
 : c-type-stack-align ( type -- align )
     dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;

basis/compiler/codegen/codegen.factor

@@ -333,25 +333,22 @@ M: reg-class reg-class-full?
     [ alloc-stack-param ] [ alloc-fastcall-param ] if
     [ param-reg ] dip ;
 
-: (flatten-int-type) ( size -- seq )
+: (flatten-int-type) ( type -- seq )
-    cell /i "void*" c-type <repetition> ;
+    stack-size cell align cell /i void* c-type <repetition> ;
 
 GENERIC: flatten-value-type ( type -- types )
 
 M: object flatten-value-type 1array ;
-
+M: struct-c-type flatten-value-type (flatten-int-type) ;
-M: struct-c-type flatten-value-type ( type -- types )
+M: long-long-type flatten-value-type (flatten-int-type) ;
-    stack-size cell align (flatten-int-type) ;
+M: c-type-name flatten-value-type c-type flatten-value-type ;
-
-M: long-long-type flatten-value-type ( type -- types )
-    stack-size cell align (flatten-int-type) ;
 
 : flatten-value-types ( params -- params )
     #! Convert value type structs to consecutive void*s.
     [
         0 [
             c-type
-            [ parameter-align (flatten-int-type) % ] keep
+            [ parameter-align cell /i void* c-type <repetition> % ] keep
             [ stack-size cell align + ] keep
             flatten-value-type %
         ] reduce drop

basis/cpu/x86/32/32.factor

@@ -57,12 +57,12 @@ M:: x86.32 %dispatch ( src temp -- )
 
 M: x86.32 pic-tail-reg EBX ;
 
-M: x86.32 reserved-area-size 0 ;
+M: x86.32 reserved-area-size 4 cells ;
 
 M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
 
-: push-vm-ptr ( -- )
+: save-vm-ptr ( n -- )
-    0 PUSH 0 rc-absolute-cell rel-vm ; ! push the vm ptr as an argument
+    stack@ 0 MOV 0 rc-absolute-cell rel-vm ;
 
 M: x86.32 return-struct-in-registers? ( c-type -- ? )
     c-type
@@ -72,44 +72,34 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? )
     and or ;
 
 : struct-return@ ( n -- operand )
-    [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
+    [ next-stack@ ] [ stack-frame get params>> param@ ] if* ;
 
 ! On x86, parameters are never passed in registers.
 M: int-regs return-reg drop EAX ;
 M: int-regs param-regs drop { } ;
 M: float-regs param-regs drop { } ;
 
-GENERIC: push-return-reg ( rep -- )
+GENERIC: load-return-reg ( src rep -- )
-GENERIC: load-return-reg ( n rep -- )
+GENERIC: store-return-reg ( dst rep -- )
-GENERIC: store-return-reg ( n rep -- )
 
-M: int-rep push-return-reg drop EAX PUSH ;
+M: int-rep load-return-reg drop EAX swap MOV ;
-M: int-rep load-return-reg drop EAX swap next-stack@ MOV ;
+M: int-rep store-return-reg drop EAX MOV ;
-M: int-rep store-return-reg drop stack@ EAX MOV ;
 
-M: float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
+M: float-rep load-return-reg drop FLDS ;
-M: float-rep load-return-reg drop next-stack@ FLDS ;
+M: float-rep store-return-reg drop FSTPS ;
-M: float-rep store-return-reg drop stack@ FSTPS ;
 
-M: double-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
+M: double-rep load-return-reg drop FLDL ;
-M: double-rep load-return-reg drop next-stack@ FLDL ;
+M: double-rep store-return-reg drop FSTPL ;
-M: double-rep store-return-reg drop stack@ FSTPL ;
-
-: align-sub ( n -- )
-    [ align-stack ] keep - decr-stack-reg ;
-
-: align-add ( n -- )
-    align-stack incr-stack-reg ;
-
-: with-aligned-stack ( n quot -- )
-    '[ align-sub @ ] [ align-add ] bi ; inline
 
 M: x86.32 %prologue ( n -- )
     dup PUSH
     0 PUSH rc-absolute-cell rel-this
     3 cells - decr-stack-reg ;
 
-M: x86.32 %load-param-reg 3drop ;
+M: x86.32 %load-param-reg
+    stack-params assert=
+    [ [ EAX ] dip param@ MOV ] dip
+    stack@ EAX MOV ;
 
 M: x86.32 %save-param-reg 3drop ;
 
@@ -118,15 +108,13 @@ M: x86.32 %save-param-reg 3drop ;
     #! are boxing a return value of a C function. If n is an
     #! integer, push [ESP+n] on the stack; we are boxing a
     #! parameter being passed to a callback from C.
-    over [ load-return-reg ] [ 2drop ] if ;
+    over [ [ next-stack@ ] dip load-return-reg ] [ 2drop ] if ;
 
 M:: x86.32 %box ( n rep func -- )
     n rep (%box)
-    rep rep-size cell + [
+    rep rep-size save-vm-ptr
-        push-vm-ptr
+    0 stack@ rep store-return-reg
-        rep push-return-reg
+    func f %alien-invoke ;
-        func f %alien-invoke
-    ] with-aligned-stack ;
 
 : (%box-long-long) ( n -- )
     [
@@ -136,41 +124,31 @@ M:: x86.32 %box ( n rep func -- )
 
 M: x86.32 %box-long-long ( n func -- )
     [ (%box-long-long) ] dip
-    12 [
+    8 save-vm-ptr
-        push-vm-ptr
+    4 stack@ EDX MOV
-        EDX PUSH
+    0 stack@ EAX MOV
-        EAX PUSH
+    f %alien-invoke ;
-        f %alien-invoke
-    ] with-aligned-stack ;
 
 M:: x86.32 %box-large-struct ( n c-type -- )
-    ! Compute destination address
     EDX n struct-return@ LEA
-    12 [
+    8 save-vm-ptr
-        push-vm-ptr
+    4 stack@ c-type heap-size MOV
-        ! Push struct size
+    0 stack@ EDX MOV
-        c-type heap-size PUSH
+    "box_value_struct" f %alien-invoke ;
-        ! Push destination address
-        EDX PUSH
-        ! Copy the struct from the C stack
-        "box_value_struct" f %alien-invoke
-    ] with-aligned-stack ;
 
 M: x86.32 %prepare-box-struct ( -- )
     ! Compute target address for value struct return
     EAX f struct-return@ LEA
     ! Store it as the first parameter
-    0 stack@ EAX MOV ;
+    0 param@ EAX MOV ;
 
 M: x86.32 %box-small-struct ( c-type -- )
     #! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
-    16 [
+    12 save-vm-ptr
-        push-vm-ptr
+    8 stack@ swap heap-size MOV
-        heap-size PUSH
+    4 stack@ EDX MOV
-        EDX PUSH
+    0 stack@ EAX MOV
-        EAX PUSH
+    "box_small_struct" f %alien-invoke ;
-        "box_small_struct" f %alien-invoke
-    ] with-aligned-stack ;
 
 M: x86.32 %prepare-unbox ( -- )
     #! Move top of data stack to EAX.
@@ -178,14 +156,9 @@ M: x86.32 %prepare-unbox ( -- )
     ESI 4 SUB ;
 
 : call-unbox-func ( func -- )
-    8 [
+    4 save-vm-ptr
-        ! push the vm ptr as an argument
+    0 stack@ EAX MOV
-        push-vm-ptr
+    f %alien-invoke ;
-        ! Push parameter
-        EAX PUSH
-        ! Call the unboxer
-        f %alien-invoke
-    ] with-aligned-stack ;
 
 M: x86.32 %unbox ( n rep func -- )
     #! The value being unboxed must already be in EAX.
@@ -194,37 +167,33 @@ M: x86.32 %unbox ( n rep func -- )
     #! a parameter to a C function about to be called.
     call-unbox-func
     ! Store the return value on the C stack
-    over [ store-return-reg ] [ 2drop ] if ;
+    over [ [ param@ ] dip store-return-reg ] [ 2drop ] if ;
 
 M: x86.32 %unbox-long-long ( n func -- )
     call-unbox-func
     ! Store the return value on the C stack
     [
-        dup stack@ EAX MOV
+        dup param@ EAX MOV
-        cell + stack@ EDX MOV
+        4 + param@ EDX MOV
     ] when* ;
 
 : %unbox-struct-1 ( -- )
     #! Alien must be in EAX.
-    8 [
+    4 save-vm-ptr
-        push-vm-ptr
+    0 stack@ EAX MOV
-        EAX PUSH
     "alien_offset" f %alien-invoke
     ! Load first cell
-        EAX EAX [] MOV
+    EAX EAX [] MOV ;
-    ] with-aligned-stack ;
 
 : %unbox-struct-2 ( -- )
     #! Alien must be in EAX.
-    8 [
+    4 save-vm-ptr
-        push-vm-ptr
+    0 stack@ EAX MOV
-        EAX PUSH
     "alien_offset" f %alien-invoke
     ! Load second cell
     EDX EAX 4 [+] MOV
     ! Load first cell
-        EAX EAX [] MOV
+    EAX EAX [] MOV ;
-    ] with-aligned-stack ;
 
 M: x86 %unbox-small-struct ( size -- )
     #! Alien must be in EAX.
@@ -236,63 +205,47 @@ M: x86 %unbox-small-struct ( size -- )
 M:: x86.32 %unbox-large-struct ( n c-type -- )
     ! Alien must be in EAX.
     ! Compute destination address
-    EDX n stack@ LEA
+    EDX n param@ LEA
-    16 [
+    12 save-vm-ptr
-        push-vm-ptr
+    8 stack@ c-type heap-size MOV
-        ! Push struct size
+    4 stack@ EDX MOV
-        c-type heap-size PUSH
+    0 stack@ EAX MOV
-        ! Push destination address
+    "to_value_struct" f %alien-invoke ;
-        EDX PUSH
-        ! Push source address
-        EAX PUSH
-        ! Copy the struct to the stack
-        "to_value_struct" f %alien-invoke
-    ] with-aligned-stack ;
 
 M: x86.32 %nest-stacks ( -- )
     ! Save current frame. See comment in vm/contexts.hpp
     EAX stack-reg stack-frame get total-size>> 3 cells - [+] LEA
-    8 [
+    4 save-vm-ptr
-        push-vm-ptr
+    0 stack@ EAX MOV
-        EAX PUSH
+    "nest_stacks" f %alien-invoke ;
-        "nest_stacks" f %alien-invoke
-    ] with-aligned-stack ;
 
 M: x86.32 %unnest-stacks ( -- )
-    4 [
+    0 save-vm-ptr
-        push-vm-ptr
+    "unnest_stacks" f %alien-invoke ;
-        "unnest_stacks" f %alien-invoke
-    ] with-aligned-stack ;
 
 M: x86.32 %prepare-alien-indirect ( -- )
-    4 [
+    0 save-vm-ptr
-        push-vm-ptr
     "unbox_alien" f %alien-invoke
-    ] with-aligned-stack
     EBP EAX MOV ;
 
 M: x86.32 %alien-indirect ( -- )
     EBP CALL ;
 
 M: x86.32 %alien-callback ( quot -- )
+    ! Fastcall
     param-reg-1 swap %load-reference
     param-reg-2 %mov-vm-ptr
     "c_to_factor" f %alien-invoke ;
 
 M: x86.32 %callback-value ( ctype -- )
-    ! Align C stack
-    ESP 12 SUB
     ! Save top of data stack in non-volatile register
     %prepare-unbox
-    EAX PUSH
+    4 stack@ EAX MOV
-    push-vm-ptr
+    0 save-vm-ptr
     ! Restore data/call/retain stacks
     "unnest_stacks" f %alien-invoke
-    ! Place top of data stack in EAX
+    ! Place former top of data stack back in EAX
-    temp-reg POP
+    EAX 4 stack@ MOV
-    EAX POP
-    ! Restore C stack
-    ESP 12 ADD
     ! Unbox EAX
     unbox-return ;
 
@@ -358,16 +311,10 @@ M: x86.32 %callback-return ( n -- )
 
 M:: x86.32 %call-gc ( gc-root-count temp -- )
     temp gc-root-base param@ LEA
-    12 [
+    8 save-vm-ptr
-        ! Pass the VM ptr as the third parameter
+    4 stack@ gc-root-count MOV
-        push-vm-ptr
+    0 stack@ temp MOV
-        ! Pass number of roots as second parameter
+    "inline_gc" f %alien-invoke ;
-        gc-root-count PUSH 
-        ! Pass pointer to start of GC roots as first parameter
-        temp PUSH 
-        ! Call GC
-        "inline_gc" f %alien-invoke
-    ] with-aligned-stack ;
 
 M: x86.32 dummy-stack-params? f ;
 
@@ -375,10 +322,13 @@ M: x86.32 dummy-int-params? f ;
 
 M: x86.32 dummy-fp-params? f ;
 
+! Dreadful
+M: object flatten-value-type (flatten-int-type) ;
+
 os windows? [
-    cell "longlong" c-type (>>align)
+    cell longlong c-type (>>align)
-    cell "ulonglong" c-type (>>align)
+    cell ulonglong c-type (>>align)
-    4 "double" c-type (>>align)
+    4 double c-type (>>align)
 ] unless
 
 check-sse