diff --git a/basis/alien/remote-control/remote-control.factor b/basis/alien/remote-control/remote-control.factor index 4ccd0e7488..6a5644cceb 100644 --- a/basis/alien/remote-control/remote-control.factor +++ b/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 -threads words kernel.private kernel io.encodings.utf8 eval ; +USING: accessors alien alien.c-types alien.data alien.strings +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 diff --git a/basis/compiler/alien/alien.factor b/basis/compiler/alien/alien.factor index dd2b029266..f43c11abcf 100644 --- a/basis/compiler/alien/alien.factor +++ b/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 ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 31918658c4..ca037b4d6f 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/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 ) - cell /i "void*" c-type ; +: (flatten-int-type) ( type -- seq ) + stack-size cell align cell /i void* c-type ; GENERIC: flatten-value-type ( type -- types ) M: object flatten-value-type 1array ; - -M: struct-c-type flatten-value-type ( type -- types ) - stack-size cell align (flatten-int-type) ; - -M: long-long-type flatten-value-type ( type -- types ) - stack-size cell align (flatten-int-type) ; +M: struct-c-type flatten-value-type (flatten-int-type) ; +M: long-long-type flatten-value-type (flatten-int-type) ; +M: c-type-name flatten-value-type c-type flatten-value-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 % ] keep [ stack-size cell align + ] keep flatten-value-type % ] reduce drop diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 3ce1374491..41b4b9304d 100755 --- a/basis/cpu/x86/32/32.factor +++ b/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 ( -- ) - 0 PUSH 0 rc-absolute-cell rel-vm ; ! push the vm ptr as an argument +: save-vm-ptr ( n -- ) + 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 ( n rep -- ) -GENERIC: store-return-reg ( n rep -- ) +GENERIC: load-return-reg ( src rep -- ) +GENERIC: store-return-reg ( dst rep -- ) -M: int-rep push-return-reg drop EAX PUSH ; -M: int-rep load-return-reg drop EAX swap next-stack@ MOV ; -M: int-rep store-return-reg drop stack@ EAX MOV ; +M: int-rep load-return-reg drop EAX swap MOV ; +M: int-rep store-return-reg drop EAX MOV ; -M: float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ; -M: float-rep load-return-reg drop next-stack@ FLDS ; -M: float-rep store-return-reg drop stack@ FSTPS ; +M: float-rep load-return-reg drop FLDS ; +M: float-rep store-return-reg drop FSTPS ; -M: double-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ; -M: double-rep load-return-reg drop next-stack@ FLDL ; -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: double-rep load-return-reg drop FLDL ; +M: double-rep store-return-reg drop FSTPL ; 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,16 +108,14 @@ 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 + [ - push-vm-ptr - rep push-return-reg - func f %alien-invoke - ] with-aligned-stack ; - + rep rep-size save-vm-ptr + 0 stack@ rep store-return-reg + func f %alien-invoke ; + : (%box-long-long) ( n -- ) [ EDX over next-stack@ MOV @@ -136,41 +124,31 @@ M:: x86.32 %box ( n rep func -- ) M: x86.32 %box-long-long ( n func -- ) [ (%box-long-long) ] dip - 12 [ - push-vm-ptr - EDX PUSH - EAX PUSH - f %alien-invoke - ] with-aligned-stack ; + 8 save-vm-ptr + 4 stack@ EDX MOV + 0 stack@ EAX MOV + f %alien-invoke ; M:: x86.32 %box-large-struct ( n c-type -- ) - ! Compute destination address EDX n struct-return@ LEA - 12 [ - push-vm-ptr - ! Push struct size - c-type heap-size PUSH - ! Push destination address - EDX PUSH - ! Copy the struct from the C stack - "box_value_struct" f %alien-invoke - ] with-aligned-stack ; + 8 save-vm-ptr + 4 stack@ c-type heap-size MOV + 0 stack@ EDX MOV + "box_value_struct" f %alien-invoke ; 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 [ - push-vm-ptr - heap-size PUSH - EDX PUSH - EAX PUSH - "box_small_struct" f %alien-invoke - ] with-aligned-stack ; + 12 save-vm-ptr + 8 stack@ swap heap-size MOV + 4 stack@ EDX MOV + 0 stack@ EAX MOV + "box_small_struct" f %alien-invoke ; 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 [ - ! push the vm ptr as an argument - push-vm-ptr - ! Push parameter - EAX PUSH - ! Call the unboxer - f %alien-invoke - ] with-aligned-stack ; + 4 save-vm-ptr + 0 stack@ EAX MOV + f %alien-invoke ; 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 - cell + stack@ EDX MOV + dup param@ EAX MOV + 4 + param@ EDX MOV ] when* ; : %unbox-struct-1 ( -- ) #! Alien must be in EAX. - 8 [ - push-vm-ptr - EAX PUSH - "alien_offset" f %alien-invoke - ! Load first cell - EAX EAX [] MOV - ] with-aligned-stack ; + 4 save-vm-ptr + 0 stack@ EAX MOV + "alien_offset" f %alien-invoke + ! Load first cell + EAX EAX [] MOV ; : %unbox-struct-2 ( -- ) #! Alien must be in EAX. - 8 [ - push-vm-ptr - EAX PUSH - "alien_offset" f %alien-invoke - ! Load second cell - EDX EAX 4 [+] MOV - ! Load first cell - EAX EAX [] MOV - ] with-aligned-stack ; + 4 save-vm-ptr + 0 stack@ EAX MOV + "alien_offset" f %alien-invoke + ! Load second cell + EDX EAX 4 [+] MOV + ! Load first cell + EAX EAX [] MOV ; 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 - 16 [ - push-vm-ptr - ! Push struct size - c-type heap-size PUSH - ! Push destination address - EDX PUSH - ! Push source address - EAX PUSH - ! Copy the struct to the stack - "to_value_struct" f %alien-invoke - ] with-aligned-stack ; + EDX n param@ LEA + 12 save-vm-ptr + 8 stack@ c-type heap-size MOV + 4 stack@ EDX MOV + 0 stack@ EAX MOV + "to_value_struct" f %alien-invoke ; 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 [ - push-vm-ptr - EAX PUSH - "nest_stacks" f %alien-invoke - ] with-aligned-stack ; + 4 save-vm-ptr + 0 stack@ EAX MOV + "nest_stacks" f %alien-invoke ; M: x86.32 %unnest-stacks ( -- ) - 4 [ - push-vm-ptr - "unnest_stacks" f %alien-invoke - ] with-aligned-stack ; + 0 save-vm-ptr + "unnest_stacks" f %alien-invoke ; M: x86.32 %prepare-alien-indirect ( -- ) - 4 [ - push-vm-ptr - "unbox_alien" f %alien-invoke - ] with-aligned-stack + 0 save-vm-ptr + "unbox_alien" f %alien-invoke 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 - push-vm-ptr + 4 stack@ EAX MOV + 0 save-vm-ptr ! Restore data/call/retain stacks "unnest_stacks" f %alien-invoke - ! Place top of data stack in EAX - temp-reg POP - EAX POP - ! Restore C stack - ESP 12 ADD + ! Place former top of data stack back in EAX + EAX 4 stack@ MOV ! 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 [ - ! Pass the VM ptr as the third parameter - push-vm-ptr - ! Pass number of roots as second parameter - 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 ; + 8 save-vm-ptr + 4 stack@ gc-root-count MOV + 0 stack@ temp MOV + "inline_gc" f %alien-invoke ; 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 "ulonglong" c-type (>>align) - 4 "double" c-type (>>align) + cell longlong c-type (>>align) + cell ulonglong c-type (>>align) + 4 double c-type (>>align) ] unless check-sse