From dafa068f348580207275edc404f41149303638bd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 20 Oct 2009 02:18:21 -0500 Subject: [PATCH 1/7] ui.gadgets.controls: fix load error --- extra/ui/gadgets/controls/controls.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/ui/gadgets/controls/controls.factor b/extra/ui/gadgets/controls/controls.factor index 649c9052fd..0c7841b11f 100644 --- a/extra/ui/gadgets/controls/controls.factor +++ b/extra/ui/gadgets/controls/controls.factor @@ -1,7 +1,7 @@ USING: accessors assocs arrays kernel models monads sequences models.combinators ui.gadgets ui.gadgets.borders ui.gadgets.buttons -ui.gadgets.buttons.private ui.gadgets.editors words images.loader -ui.gadgets.scrollers ui.images vocabs.parser lexer +ui.gadgets.buttons.private ui.gadgets.editors ui.gadgets.editors.private +words images.loader ui.gadgets.scrollers ui.images vocabs.parser lexer models.range ui.gadgets.sliders ; QUALIFIED-WITH: ui.gadgets.sliders slider QUALIFIED-WITH: ui.gadgets.tables tbl From 5f3c94896fe6eeb4675ef73e6df386760943f420 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 20 Oct 2009 02:18:28 -0500 Subject: [PATCH 2/7] specialized-arrays: fix unit test --- .../specialized-arrays-tests.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index 3226557494..423c7ad1ee 100755 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -122,10 +122,6 @@ SPECIALIZED-ARRAY: fixed-string ! If the C type doesn't exist, don't generate a vocab SYMBOL: __does_not_exist__ -[ ] [ - [ __does_not_exist__ specialized-array-vocab forget-vocab ] with-compilation-unit -] unit-test - [ """ IN: specialized-arrays.tests @@ -151,4 +147,9 @@ SPECIALIZED-ARRAY: __does_not_exist__ deferred? ] unit-test -[ \ __does_not_exist__ forget ] with-compilation-unit +[ ] [ + [ + \ __does_not_exist__ forget + __does_not_exist__ specialized-array-vocab forget-vocab + ] with-compilation-unit +] unit-test From 560b6f45cc6753c56e361acb0ca7e563fb1637e6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 20 Oct 2009 04:15:10 -0500 Subject: [PATCH 3/7] compiler, cpu.x86.32: clean up FFI implementation, in particular 32-bit x86-specific backend --- .../remote-control/remote-control.factor | 11 +- basis/compiler/alien/alien.factor | 4 +- basis/compiler/codegen/codegen.factor | 15 +- basis/cpu/x86/32/32.factor | 212 +++++++----------- 4 files changed, 95 insertions(+), 147 deletions(-) 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 From 1e7893b6ce9a3d7a3c5c4174b26277d3d635c66d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 20 Oct 2009 04:31:48 -0500 Subject: [PATCH 4/7] compiler: FFI is now slightly more efficient when unboxing parameters, only changes data stack height once --- basis/compiler/alien/alien.factor | 3 +-- basis/compiler/cfg/builder/builder.factor | 2 +- basis/compiler/codegen/codegen.factor | 20 ++++++++++++-------- basis/cpu/architecture/architecture.factor | 2 +- basis/cpu/ppc/ppc.factor | 6 ++---- basis/cpu/x86/32/32.factor | 7 ++----- basis/cpu/x86/64/64.factor | 10 +++------- 7 files changed, 22 insertions(+), 28 deletions(-) diff --git a/basis/compiler/alien/alien.factor b/basis/compiler/alien/alien.factor index f43c11abcf..6a63b719df 100644 --- a/basis/compiler/alien/alien.factor +++ b/basis/compiler/alien/alien.factor @@ -20,8 +20,7 @@ IN: compiler.alien : parameter-align ( n type -- n delta ) [ c-type-stack-align align dup ] [ drop ] 2bi - ; -: parameter-sizes ( types -- total offsets ) - #! Compute stack frame locations. +: parameter-offsets ( types -- total offsets ) [ 0 [ [ parameter-align drop dup , ] keep stack-size + diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 74586c6eeb..e0f921259c 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -212,7 +212,7 @@ M: #terminate emit-node drop ##no-tco end-basic-block ; stack-frame new swap [ return>> return-size >>return ] - [ alien-parameters parameter-sizes drop >>params ] bi ; + [ alien-parameters parameter-offsets drop >>params ] bi ; : alien-node-height ( params -- ) [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index ca037b4d6f..e8f3ca7d64 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -355,10 +355,7 @@ M: c-type-name flatten-value-type c-type flatten-value-type ; ] { } make ; : each-parameter ( parameters quot -- ) - [ [ parameter-sizes nip ] keep ] dip 2each ; inline - -: reverse-each-parameter ( parameters quot -- ) - [ [ parameter-sizes nip ] keep ] dip 2reverse-each ; inline + [ [ parameter-offsets nip ] keep ] dip 2each ; inline : reset-fastcall-counts ( -- ) { int-regs float-regs stack-params } [ 0 swap set ] each ; @@ -375,10 +372,17 @@ M: c-type-name flatten-value-type c-type flatten-value-type ; [ '[ alloc-parameter _ execute ] ] bi* each-parameter ; inline +: reverse-each-parameter ( parameters quot -- ) + [ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline + +: prepare-unbox-parameters ( parameters -- offsets types indices ) + [ parameter-offsets nip ] [ ] [ length iota reverse ] tri ; + : unbox-parameters ( offset node -- ) - parameters>> [ - %prepare-unbox [ over + ] dip unbox-parameter - ] reverse-each-parameter drop ; + parameters>> swap + '[ prepare-unbox-parameters [ %prepare-unbox [ _ + ] dip unbox-parameter ] 3each ] + [ length neg %inc-d ] + bi ; : prepare-box-struct ( node -- offset ) #! Return offset on C stack where to store unboxed @@ -410,7 +414,7 @@ M: c-type-name flatten-value-type c-type flatten-value-type ; ] if ; : stdcall-mangle ( symbol params -- symbol ) - parameters>> parameter-sizes drop number>string "@" glue ; + parameters>> parameter-offsets drop number>string "@" glue ; : alien-invoke-dlsym ( params -- symbols dll ) [ [ function>> dup ] keep stdcall-mangle 2array ] diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 2f0bdbdcbf..c411d97558 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -463,7 +463,7 @@ HOOK: dummy-int-params? cpu ( -- ? ) ! If t, all int parameters are shadowed by dummy FP parameters HOOK: dummy-fp-params? cpu ( -- ? ) -HOOK: %prepare-unbox cpu ( -- ) +HOOK: %prepare-unbox cpu ( n -- ) HOOK: %unbox cpu ( n rep func -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 02e1d7cb94..517aa7587d 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -577,10 +577,8 @@ M:: ppc %save-param-reg ( stack reg rep -- ) M:: ppc %load-param-reg ( stack reg rep -- ) reg stack local@ rep load-from-frame ; -M: ppc %prepare-unbox ( -- ) - ! First parameter is top of stack - 3 ds-reg 0 LWZ - ds-reg dup cell SUBI ; +M: ppc %prepare-unbox ( n -- ) + [ 3 ] dip loc>operand LWZ ; M: ppc %unbox ( n rep func -- ) ! Value must be in r3 diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 41b4b9304d..4ab2e9ba7a 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -151,9 +151,7 @@ M: x86.32 %box-small-struct ( c-type -- ) "box_small_struct" f %alien-invoke ; M: x86.32 %prepare-unbox ( -- ) - #! Move top of data stack to EAX. - EAX ESI [] MOV - ESI 4 SUB ; + EAX swap ds-reg reg-stack MOV ; : call-unbox-func ( func -- ) 4 save-vm-ptr @@ -238,8 +236,7 @@ M: x86.32 %alien-callback ( quot -- ) "c_to_factor" f %alien-invoke ; M: x86.32 %callback-value ( ctype -- ) - ! Save top of data stack in non-volatile register - %prepare-unbox + 0 %prepare-unbox 4 stack@ EAX MOV 0 save-vm-ptr ! Restore data/call/retain stacks diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index c34530c307..1f6bba5a97 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -84,10 +84,8 @@ M: x86 %load-param-reg [ swap param@ ] dip %copy ; call ] with-scope ; inline -M: x86.64 %prepare-unbox ( -- ) - ! First parameter is top of stack - param-reg-1 R14 [] MOV - R14 cell SUB ; +M: x86.64 %prepare-unbox ( n -- ) + param-reg-1 swap ds-reg reg-stack MOV ; M:: x86.64 %unbox ( n rep func -- ) param-reg-2 %mov-vm-ptr @@ -217,9 +215,7 @@ M: x86.64 %alien-callback ( quot -- ) "c_to_factor" f %alien-invoke ; M: x86.64 %callback-value ( ctype -- ) - ! Save top of data stack - %prepare-unbox - ! Save top of data stack + 0 %prepare-unbox RSP 8 SUB param-reg-1 PUSH param-reg-1 %mov-vm-ptr From 18be7e1f37e4c0dfb8b90613bf4691ad4e4dcc09 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 20 Oct 2009 05:02:42 -0500 Subject: [PATCH 5/7] cpu.x86.32: only create 16-byte parameter area if the word calls into the VM --- .../build-stack-frame.factor | 4 +- basis/compiler/cfg/builder/builder.factor | 3 +- .../cfg/stack-frame/stack-frame.factor | 7 +++- basis/cpu/x86/32/32.factor | 23 ++++++---- basis/cpu/x86/64/64.factor | 42 ++++++++++--------- basis/cpu/x86/64/unix/unix.factor | 2 +- basis/cpu/x86/64/winnt/winnt.factor | 2 +- basis/cpu/x86/x86.factor | 19 ++++++--- 8 files changed, 63 insertions(+), 39 deletions(-) diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index b5510c7142..1f01bc438b 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -27,7 +27,9 @@ M: ##call compute-stack-frame* M: ##gc compute-stack-frame* frame-required? on - stack-frame new swap tagged-values>> length cells >>gc-root-size + stack-frame new + swap tagged-values>> length cells >>gc-root-size + t >>calls-vm? request-stack-frame ; M: _spill-area-size compute-stack-frame* diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index e0f921259c..11aae28bf3 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -212,7 +212,8 @@ M: #terminate emit-node drop ##no-tco end-basic-block ; stack-frame new swap [ return>> return-size >>return ] - [ alien-parameters parameter-offsets drop >>params ] bi ; + [ alien-parameters parameter-offsets drop >>params ] bi + t >>calls-vm? ; : alien-node-height ( params -- ) [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; diff --git a/basis/compiler/cfg/stack-frame/stack-frame.factor b/basis/compiler/cfg/stack-frame/stack-frame.factor index 4b071cb43c..3cfade23e1 100644 --- a/basis/compiler/cfg/stack-frame/stack-frame.factor +++ b/basis/compiler/cfg/stack-frame/stack-frame.factor @@ -9,7 +9,8 @@ TUPLE: stack-frame { return integer } { total-size integer } { gc-root-size integer } -{ spill-area-size integer } ; +{ spill-area-size integer } +{ calls-vm? boolean } ; ! Stack frame utilities : param-base ( -- n ) @@ -35,7 +36,9 @@ TUPLE: stack-frame : max-stack-frame ( frame1 frame2 -- frame3 ) [ stack-frame new ] 2dip + { [ [ params>> ] bi@ max >>params ] [ [ return>> ] bi@ max >>return ] [ [ gc-root-size>> ] bi@ max >>gc-root-size ] - 2tri ; \ No newline at end of file + [ [ calls-vm?>> ] bi@ or >>calls-vm? ] + } 2cleave ; \ No newline at end of file diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 4ab2e9ba7a..cff5c561c8 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -25,6 +25,11 @@ M: x86.32 rs-reg EDI ; M: x86.32 stack-reg ESP ; M: x86.32 temp-reg ECX ; +: local@ ( n -- op ) + stack-frame get extra-stack-space dup 16 assert= + stack@ ; + +M: x86.32 extra-stack-space calls-vm?>> 16 0 ? ; + M: x86.32 %mark-card drop HEX: ffffffff [+] card-mark MOV building get pop @@ -57,7 +62,7 @@ M:: x86.32 %dispatch ( src temp -- ) M: x86.32 pic-tail-reg EBX ; -M: x86.32 reserved-area-size 4 cells ; +M: x86.32 reserved-stack-space 4 cells ; M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; @@ -72,7 +77,7 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? ) and or ; : struct-return@ ( n -- operand ) - [ next-stack@ ] [ stack-frame get params>> param@ ] if* ; + [ next-stack@ ] [ stack-frame get params>> local@ ] if* ; ! On x86, parameters are never passed in registers. M: int-regs return-reg drop EAX ; @@ -98,7 +103,7 @@ M: x86.32 %prologue ( n -- ) M: x86.32 %load-param-reg stack-params assert= - [ [ EAX ] dip param@ MOV ] dip + [ [ EAX ] dip local@ MOV ] dip stack@ EAX MOV ; M: x86.32 %save-param-reg 3drop ; @@ -140,7 +145,7 @@ 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 param@ EAX MOV ; + 0 local@ EAX MOV ; M: x86.32 %box-small-struct ( c-type -- ) #! Box a <= 8-byte struct returned in EAX:EDX. OS X only. @@ -165,14 +170,14 @@ 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 [ [ param@ ] dip store-return-reg ] [ 2drop ] if ; + over [ [ local@ ] 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 param@ EAX MOV - 4 + param@ EDX MOV + [ local@ EAX MOV ] + [ 4 + local@ EDX MOV ] bi ] when* ; : %unbox-struct-1 ( -- ) @@ -203,7 +208,7 @@ 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 param@ LEA + EDX n local@ LEA 12 save-vm-ptr 8 stack@ c-type heap-size MOV 4 stack@ EDX MOV @@ -307,7 +312,7 @@ M: x86.32 %callback-return ( n -- ) } cond RET ; M:: x86.32 %call-gc ( gc-root-count temp -- ) - temp gc-root-base param@ LEA + temp gc-root-base special@ LEA 8 save-vm-ptr 4 stack@ gc-root-count MOV 0 stack@ temp MOV diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 1f6bba5a97..cbc5c4d7e5 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -8,6 +8,22 @@ compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 cpu.architecture ; IN: cpu.x86.64 +: param-reg-1 ( -- reg ) int-regs param-regs first ; inline +: param-reg-2 ( -- reg ) int-regs param-regs second ; inline +: param-reg-3 ( -- reg ) int-regs param-regs third ; inline +: param-reg-4 ( -- reg ) int-regs param-regs fourth ; inline + +M: x86.64 pic-tail-reg RBX ; + +M: int-regs return-reg drop RAX ; +M: float-regs return-reg drop XMM0 ; + +M: x86.64 ds-reg R14 ; +M: x86.64 rs-reg R15 ; +M: x86.64 stack-reg RSP ; + +M: x86.64 extra-stack-space drop 0 ; + M: x86.64 machine-registers { { int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } } @@ -17,9 +33,13 @@ M: x86.64 machine-registers } } } ; -M: x86.64 ds-reg R14 ; -M: x86.64 rs-reg R15 ; -M: x86.64 stack-reg RSP ; +: param@ ( n -- op ) reserved-stack-space + stack@ ; + +M: x86.64 %prologue ( n -- ) + temp-reg 0 MOV rc-absolute-cell rel-this + dup PUSH + temp-reg PUSH + stack-reg swap 3 cells - SUB ; : load-cards-offset ( dst -- ) 0 MOV rc-absolute-cell rel-cards-offset ; @@ -50,22 +70,6 @@ M:: x86.64 %dispatch ( src temp -- ) [ align-code ] bi ; -: param-reg-1 ( -- reg ) int-regs param-regs first ; inline -: param-reg-2 ( -- reg ) int-regs param-regs second ; inline -: param-reg-3 ( -- reg ) int-regs param-regs third ; inline -: param-reg-4 ( -- reg ) int-regs param-regs fourth ; inline - -M: x86.64 pic-tail-reg RBX ; - -M: int-regs return-reg drop RAX ; -M: float-regs return-reg drop XMM0 ; - -M: x86.64 %prologue ( n -- ) - temp-reg 0 MOV rc-absolute-cell rel-this - dup PUSH - temp-reg PUSH - stack-reg swap 3 cells - SUB ; - M: stack-params copy-register* drop { diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index b3d184bc97..2fb32ce733 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -12,7 +12,7 @@ M: int-regs param-regs M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ; -M: x86.64 reserved-area-size 0 ; +M: x86.64 reserved-stack-space 0 ; SYMBOL: (stack-value) ! The ABI for passing structs by value is pretty great diff --git a/basis/cpu/x86/64/winnt/winnt.factor b/basis/cpu/x86/64/winnt/winnt.factor index bbe943e06b..3ecd56bdd1 100644 --- a/basis/cpu/x86/64/winnt/winnt.factor +++ b/basis/cpu/x86/64/winnt/winnt.factor @@ -9,7 +9,7 @@ M: int-regs param-regs drop { RCX RDX R8 R9 } ; M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ; -M: x86.64 reserved-area-size 4 cells ; +M: x86.64 reserved-stack-space 4 cells ; M: x86.64 return-struct-in-registers? ( c-type -- ? ) heap-size { 1 2 4 8 } member? ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 5db2641907..4576956335 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -24,15 +24,20 @@ M: x86 vector-regs float-regs ; HOOK: stack-reg cpu ( -- reg ) -HOOK: reserved-area-size cpu ( -- n ) +HOOK: reserved-stack-space cpu ( -- n ) + +HOOK: extra-stack-space cpu ( stack-frame -- n ) : stack@ ( n -- op ) stack-reg swap [+] ; -: param@ ( n -- op ) reserved-area-size + stack@ ; +: special@ ( n -- op ) + stack-frame get extra-stack-space + + reserved-stack-space + + stack@ ; -: spill@ ( n -- op ) spill-offset param@ ; +: spill@ ( n -- op ) spill-offset special@ ; -: gc-root@ ( n -- op ) gc-root-offset param@ ; +: gc-root@ ( n -- op ) gc-root-offset special@ ; : decr-stack-reg ( n -- ) dup 0 = [ drop ] [ stack-reg swap SUB ] if ; @@ -44,7 +49,11 @@ HOOK: reserved-area-size cpu ( -- n ) os macosx? cpu x86.64? or [ 16 align ] when ; M: x86 stack-frame-size ( stack-frame -- i ) - (stack-frame-size) 3 cells reserved-area-size + + align-stack ; + [ (stack-frame-size) ] + [ extra-stack-space ] bi + + reserved-stack-space + + 3 cells + + align-stack ; ! Must be a volatile register not used for parameter passing, for safe ! use in calls in and out of C From 248f178e643991ca2cc0ad007b730da7dff3fefe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 20 Oct 2009 07:06:44 -0500 Subject: [PATCH 6/7] math.vectors: fix behavioral difference between generic vector vmin vmax and float specialized versions thereof --- basis/math/vectors/vectors.factor | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index ee417de12b..51e44d00f0 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays alien.c-types assocs kernel sequences math math.functions -hints math.order math.libm fry combinators byte-arrays accessors -locals ; +hints math.order math.libm math.floats.private fry combinators +byte-arrays accessors locals ; QUALIFIED-WITH: alien.c-types c IN: math.vectors @@ -29,8 +29,16 @@ M: object element-type drop f ; inline : [v-] ( u v -- w ) [ [-] ] 2map ; : v* ( u v -- w ) [ * ] 2map ; : v/ ( u v -- w ) [ / ] 2map ; -: vmax ( u v -- w ) [ max ] 2map ; -: vmin ( u v -- w ) [ min ] 2map ; + + + +: vmax ( u v -- w ) [ [ float-max ] [ max ] if-both-floats ] 2map ; +: vmin ( u v -- w ) [ [ float-min ] [ min ] if-both-floats ] 2map ; : v+- ( u v -- w ) [ t ] 2dip From 5346fb9f23ad111e192ee97161617196330d29f3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 20 Oct 2009 07:07:03 -0500 Subject: [PATCH 7/7] help.handbook: remove 'type index' --- basis/help/handbook/handbook-tests.factor | 1 - basis/help/handbook/handbook.factor | 4 ---- 2 files changed, 5 deletions(-) diff --git a/basis/help/handbook/handbook-tests.factor b/basis/help/handbook/handbook-tests.factor index 709d56c5d6..157d4c76e0 100644 --- a/basis/help/handbook/handbook-tests.factor +++ b/basis/help/handbook/handbook-tests.factor @@ -4,5 +4,4 @@ IN: help.handbook.tests [ ] [ "article-index" print-topic ] unit-test [ ] [ "primitive-index" print-topic ] unit-test [ ] [ "error-index" print-topic ] unit-test -[ ] [ "type-index" print-topic ] unit-test [ ] [ "class-index" print-topic ] unit-test diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 4dd3481f65..afb88bbd3c 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -239,9 +239,6 @@ ARTICLE: "primitive-index" "Primitive index" ARTICLE: "error-index" "Error index" { $index [ all-errors ] } ; -ARTICLE: "type-index" "Type index" -{ $index [ builtins get sift ] } ; - ARTICLE: "class-index" "Class index" { $heading "Built-in classes" } { $index [ classes [ builtin-class? ] filter ] } @@ -387,7 +384,6 @@ ARTICLE: "handbook" "Factor handbook" "article-index" "primitive-index" "error-index" - "type-index" "class-index" } { $heading "Explore the code base" }