diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index d33f6fa35d..e0a168cb7d 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -166,16 +166,10 @@ INSTANCE: struct-c-type value-type M: struct-c-type c-type ; -: if-value-struct ( ctype true false -- ) - [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline - -: if-small-struct ( c-type true false -- ? ) - [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline - M: struct-c-type base-type ; M: struct-c-type stack-size - [ heap-size cell align ] [ stack-size ] if-value-struct ; + dup value-struct? [ heap-size cell align ] [ drop cell ] if ; HOOK: flatten-struct-type cpu ( type -- reps ) diff --git a/basis/compiler/alien/alien.factor b/basis/compiler/alien/alien.factor index 58c5aaf734..335b8bf5a4 100644 --- a/basis/compiler/alien/alien.factor +++ b/basis/compiler/alien/alien.factor @@ -9,7 +9,5 @@ IN: compiler.alien : alien-parameters ( params -- seq ) dup parameters>> - swap return>> large-struct? [ struct-return-pointer-type prefix ] when ; - -: alien-return ( params -- type ) - return>> dup large-struct? [ drop void ] when ; + swap return>> large-struct? + [ struct-return-on-stack? (stack-value) void* ? prefix ] when ; diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index bf674fa9b9..6544d656fa 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -1,121 +1,89 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays layouts math math.order math.parser -combinators fry sequences locals alien alien.private +combinators fry make sequences locals alien alien.private alien.strings alien.c-types alien.libraries classes.struct namespaces kernel strings libc quotations cpu.architecture compiler.alien compiler.utilities compiler.tree compiler.cfg -compiler.cfg.builder compiler.cfg.builder.blocks -compiler.cfg.instructions compiler.cfg.stack-frame -compiler.cfg.stacks compiler.cfg.registers -compiler.cfg.hats ; +compiler.cfg.builder compiler.cfg.builder.alien.params +compiler.cfg.builder.blocks compiler.cfg.instructions +compiler.cfg.stack-frame compiler.cfg.stacks +compiler.cfg.registers compiler.cfg.hats ; FROM: compiler.errors => no-such-symbol no-such-library ; IN: compiler.cfg.builder.alien -GENERIC: next-fastcall-param ( rep -- ) +! output is triples with shape { vreg rep on-stack? } +GENERIC: unbox ( src c-type -- vregs ) -: ?dummy-stack-params ( rep -- ) - dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ; +M: c-type unbox + [ [ unboxer>> ] [ rep>> ] bi ^^unbox ] [ rep>> ] bi + f 3array 1array ; -: ?dummy-int-params ( rep -- ) - dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ; +M: long-long-type unbox + unboxer>> int-rep ^^unbox + 0 cell + [ + int-rep f ^^load-memory-imm + int-rep long-long-on-stack? 3array + ] bi-curry@ bi 2array ; -: ?dummy-fp-params ( rep -- ) - drop dummy-fp-params? [ float-regs inc ] when ; +GENERIC: unbox-parameter ( src c-type -- vregs ) -M: int-rep next-fastcall-param - int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ; +M: c-type unbox-parameter unbox ; -M: float-rep next-fastcall-param - float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ; +M: long-long-type unbox-parameter unbox ; -M: double-rep next-fastcall-param - float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ; +M:: struct-c-type unbox-parameter ( src c-type -- ) + src ^^unbox-any-c-ptr :> src + c-type value-struct? [ + c-type flatten-struct-type + [| rep i | + src i cells rep f ^^load-memory-imm + rep struct-on-stack? 3array + ] map-index + ] [ { { src int-rep f } } ] if ; -GENERIC# reg-class-full? 1 ( reg-class abi -- ? ) - -M: stack-params reg-class-full? 2drop t ; - -M: reg-class reg-class-full? - [ get ] swap '[ _ param-regs length ] bi >= ; - -: alloc-stack-param ( rep -- n reg-class rep ) - stack-params get - [ rep-size cell align stack-params +@ ] dip - stack-params dup ; - -: alloc-fastcall-param ( rep -- n reg-class rep ) - [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ; - -:: alloc-parameter ( rep abi -- reg rep ) - rep dup reg-class-of abi reg-class-full? - [ alloc-stack-param ] [ alloc-fastcall-param ] if - [ abi param-reg ] dip ; - -: reset-fastcall-counts ( -- ) - { int-regs float-regs stack-params } [ 0 swap set ] each ; - -: with-param-regs ( quot -- ) - #! In quot you can call alloc-parameter - [ reset-fastcall-counts call ] with-scope ; inline - -:: move-parameters ( params word -- ) - #! Moves values from C stack to registers (if word is - #! ##load-param-reg) and registers to C stack (if word is - #! ##save-param-reg). - 0 params alien-parameters flatten-c-types [ - [ params abi>> alloc-parameter word execute( offset reg rep -- ) ] - [ rep-size cell align + ] - 2bi - ] each drop ; inline - -: parameter-offsets ( types -- offsets ) - 0 [ stack-size + ] accumulate nip ; - -: prepare-parameters ( parameters -- offsets types indices ) - [ length iota ] [ parameter-offsets ] [ ] tri ; - -GENERIC: unbox-parameter ( src n c-type -- ) - -M: c-type unbox-parameter - [ rep>> ] [ unboxer>> ] bi ##unbox ; - -M: long-long-type unbox-parameter - unboxer>> ##unbox-long-long ; - -M: struct-c-type unbox-parameter - [ [ ^^unbox-any-c-ptr ] 2dip ##unbox-large-struct ] - [ base-type unbox-parameter ] - if-value-struct ; - -: unbox-parameters ( offset node -- ) - parameters>> swap - '[ - prepare-parameters +: unbox-parameters ( parameters -- vregs ) + [ + [ length iota ] keep [ - [ ^^peek ] [ _ + ] [ base-type ] tri* + [ ^^peek ] [ base-type ] bi* unbox-parameter - ] 3each + ] 2map concat ] - [ length neg ##inc-d ] - bi ; + [ length neg ##inc-d ] bi ; -: prepare-box-struct ( node -- offset ) +: prepare-struct-area ( vregs return -- vregs ) #! Return offset on C stack where to store unboxed #! parameters. If the C function is returning a structure, #! the first parameter is an implicit target area pointer, #! so we need to use a different offset. - return>> large-struct? - [ ##prepare-box-struct cell ] [ 0 ] if ; + large-struct? [ + ^^prepare-struct-area int-rep struct-return-on-stack? + 3array prefix + ] when ; + +: (objects>registers) ( vregs -- ) + ! Place instructions in reverse order, so that the + ! ##store-stack-param instructions come first. This is + ! because they are not clobber-insns and so we avoid some + ! spills that way. + [ + first3 [ dup reg-class-of reg-class-full? ] dip or + [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ] + [ [ next-reg-param ] keep \ ##store-reg-param new-insn ] + if + ] map reverse % ; : objects>registers ( params -- ) #! Generate code for unboxing a list of C types, then #! generate code for moving these parameters to registers on #! architectures where parameters are passed in registers. - [ - [ prepare-box-struct ] keep - [ unbox-parameters ] keep - \ ##load-param-reg move-parameters + [ abi>> ] [ parameters>> ] [ return>> ] tri + '[ + _ unbox-parameters + _ prepare-struct-area + (objects>registers) ] with-param-regs ; GENERIC: box-return ( c-type -- dst ) @@ -126,6 +94,9 @@ M: c-type box-return M: long-long-type box-return [ f ] dip boxer>> ^^box-long-long ; +: if-small-struct ( c-type true false -- ? ) + [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline + M: struct-c-type box-return [ ^^box-small-struct ] [ ^^box-large-struct ] if-small-struct ; @@ -189,13 +160,12 @@ M: array dlsym-valid? '[ _ dlsym ] any? ; M: #alien-invoke emit-node [ - ! Unbox parameters - dup objects>registers - ! Call function - dup alien-invoke-dlsym ##alien-invoke - ! Box return value - dup ##cleanup - box-return* + { + [ objects>registers ] + [ alien-invoke-dlsym ##alien-invoke ] + [ stack-cleanup ##cleanup ] + [ box-return* ] + } cleave ] emit-alien-node ; M: #alien-indirect emit-node @@ -204,7 +174,7 @@ M: #alien-indirect emit-node { [ drop objects>registers ] [ nip ##alien-indirect ] - [ drop ##cleanup ] + [ drop stack-cleanup ##cleanup ] [ drop box-return* ] } 2cleave ] emit-alien-node ; @@ -225,9 +195,18 @@ M: c-type box-parameter M: long-long-type box-parameter boxer>> ^^box-long-long ; +: if-value-struct ( ctype true false -- ) + [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline + M: struct-c-type box-parameter [ ^^box-large-struct ] [ base-type box-parameter ] if-value-struct ; +: parameter-offsets ( types -- offsets ) + 0 [ stack-size + ] accumulate nip ; + +: prepare-parameters ( parameters -- offsets types indices ) + [ length iota ] [ parameter-offsets ] [ ] tri ; + : box-parameters ( params -- ) alien-parameters [ length ##inc-d ] @@ -239,10 +218,21 @@ M: struct-c-type box-parameter ] 3each ] bi ; -: registers>objects ( node -- ) +:: alloc-parameter ( rep -- reg rep ) + rep dup reg-class-of reg-class-full? + [ alloc-stack-param stack-params ] [ [ next-reg-param ] keep ] if ; + +: (registers>objects) ( params -- ) + [ 0 ] dip alien-parameters flatten-c-types [ + [ alloc-parameter ##save-param-reg ] + [ rep-size cell align + ] + 2bi + ] each drop ; inline + +: registers>objects ( params -- ) ! Generate code for boxing input parameters in a callback. - [ - dup \ ##save-param-reg move-parameters + dup abi>> [ + dup (registers>objects) ##begin-callback next-vreg next-vreg ##restore-context box-parameters @@ -267,14 +257,13 @@ M: struct-c-type box-parameter GENERIC: unbox-return ( src c-type -- ) M: c-type unbox-return - [ f ] dip [ rep>> ] [ unboxer>> ] bi ##unbox ; + unbox first first2 ##store-return ; M: long-long-type unbox-return - [ f ] dip unboxer>> ##unbox-long-long ; + unbox first2 [ first ] bi@ ##store-long-long-return ; M: struct-c-type unbox-return - [ ^^unbox-any-c-ptr ] dip - [ ##unbox-small-struct ] [ ##unbox-large-struct ] if-small-struct ; + [ ^^unbox-any-c-ptr ] dip ##store-struct-return ; M: #alien-callback emit-node dup params>> xt>> dup @@ -284,11 +273,15 @@ M: #alien-callback emit-node [ registers>objects ] [ wrap-callback-quot ##alien-callback ] [ - alien-return [ ##end-callback ] [ - [ D 0 ^^peek ] dip - ##end-callback - base-type unbox-return - ] if-void + return>> { + { [ dup void eq? ] [ drop ##end-callback ] } + { [ dup large-struct? ] [ drop ##end-callback ] } + [ + [ D 0 ^^peek ] dip + ##end-callback + base-type unbox-return + ] + } cond ] tri ] emit-alien-node ##epilogue diff --git a/basis/compiler/cfg/builder/alien/params/authors.txt b/basis/compiler/cfg/builder/alien/params/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/compiler/cfg/builder/alien/params/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/compiler/cfg/builder/alien/params/params.factor b/basis/compiler/cfg/builder/alien/params/params.factor new file mode 100644 index 0000000000..85e9176c44 --- /dev/null +++ b/basis/compiler/cfg/builder/alien/params/params.factor @@ -0,0 +1,49 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: cpu.architecture fry kernel layouts math math.order +namespaces sequences vectors ; +IN: compiler.cfg.builder.alien.params + +: alloc-stack-param ( rep -- n ) + stack-params get + [ rep-size cell align stack-params +@ ] dip ; + +: ?dummy-stack-params ( rep -- ) + dummy-stack-params? [ alloc-stack-param drop ] [ drop ] if ; + +: ?dummy-int-params ( rep -- ) + dummy-int-params? [ + rep-size cell /i 1 max + [ int-regs get [ pop* ] unless-empty ] times + ] [ drop ] if ; + +: ?dummy-fp-params ( rep -- ) + drop dummy-fp-params? [ float-regs get [ pop* ] unless-empty ] when ; + +GENERIC: next-reg-param ( rep -- reg ) + +M: int-rep next-reg-param + [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi int-regs get pop ; + +M: float-rep next-reg-param + [ ?dummy-stack-params ] [ ?dummy-int-params ] bi float-regs get pop ; + +M: double-rep next-reg-param + [ ?dummy-stack-params ] [ ?dummy-int-params ] bi float-regs get pop ; + +GENERIC: reg-class-full? ( reg-class -- ? ) + +M: stack-params reg-class-full? drop t ; + +M: reg-class reg-class-full? get empty? ; + +: init-reg-class ( abi reg-class -- ) + [ swap param-regs >vector ] keep set ; + +: with-param-regs ( abi quot -- ) + '[ + [ int-regs init-reg-class ] + [ float-regs init-reg-class ] bi + 0 stack-params set + @ + ] with-scope ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 36e840fc9e..28b52e7a4f 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -612,6 +612,33 @@ literal: offset ; INSN: ##stack-frame literal: stack-frame ; +INSN: ##unbox +def: dst +use: src/tagged-rep +literal: unboxer rep ; + +INSN: ##store-reg-param +use: src +literal: reg rep ; + +INSN: ##store-stack-param +use: src +literal: n rep ; + +INSN: ##store-return +use: src +literal: rep ; + +INSN: ##store-struct-return +use: src/int-rep +literal: c-type ; + +INSN: ##store-long-long-return +use: src1/int-rep src2/int-rep ; + +INSN: ##prepare-struct-area +def: dst/int-rep ; + INSN: ##box def: dst/tagged-rep literal: n rep boxer ; @@ -628,32 +655,11 @@ INSN: ##box-large-struct def: dst/tagged-rep literal: n c-type ; -INSN: ##unbox -use: src/tagged-rep -literal: n rep unboxer ; - -INSN: ##unbox-long-long -use: src/tagged-rep -literal: n unboxer ; - -INSN: ##unbox-large-struct -use: src/int-rep -literal: n c-type ; - -INSN: ##unbox-small-struct -use: src/int-rep -literal: c-type ; - -INSN: ##prepare-box-struct ; - -INSN: ##load-param-reg -literal: offset reg rep ; - INSN: ##alien-invoke literal: symbols dll ; INSN: ##cleanup -literal: params ; +literal: n ; INSN: ##alien-indirect use: src/int-rep ; @@ -815,11 +821,10 @@ UNION: clobber-insn ##box-small-struct ##box-large-struct ##unbox -##unbox-long-long -##unbox-large-struct -##unbox-small-struct -##prepare-box-struct -##load-param-reg +##store-reg-param +##store-return +##store-struct-return +##store-long-long-return ##alien-invoke ##alien-indirect ##alien-assembly diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index c1b3f04ff4..361f5896fb 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -1,7 +1,9 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs heaps kernel namespaces sequences fry math -math.order combinators arrays sorting compiler.utilities locals +USING: accessors assocs binary-search combinators +combinators.short-circuit heaps kernel namespaces +sequences fry locals math math.order arrays sorting +compiler.utilities compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation.spilling compiler.cfg.linear-scan.allocation.splitting @@ -34,15 +36,15 @@ IN: compiler.cfg.linear-scan.allocation [ drop assign-blocked-register ] } cond ; -: spill-at-sync-point ( live-interval n -- ? ) +: spill-at-sync-point ( n live-interval -- ? ) ! If the live interval has a definition at 'n', don't spill - 2dup [ uses>> ] dip - '[ [ def-rep>> ] [ n>> _ = ] bi and ] any? - [ 2drop t ] [ spill f ] if ; + 2dup find-use + { [ ] [ def-rep>> ] } 1&& + [ 2drop t ] [ swap spill f ] if ; : handle-sync-point ( n -- ) - [ active-intervals get values ] dip - '[ [ _ spill-at-sync-point ] filter! drop ] each ; + active-intervals get values + [ [ spill-at-sync-point ] with filter! drop ] with each ; :: handle-progress ( n sync? -- ) n { @@ -69,11 +71,7 @@ M: sync-point handle ( sync-point -- ) } cond ; : (allocate-registers) ( -- ) - ! If a live interval begins at the same location as a sync point, - ! process the sync point before the live interval. This ensures that the - ! return value of C function calls doesn't get spilled and reloaded - ! unnecessarily. - unhandled-sync-points get unhandled-intervals get smallest-heap + unhandled-intervals get unhandled-sync-points get smallest-heap dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ; : finish-allocation ( -- ) diff --git a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor index 6346ea41f5..e3959906d2 100644 --- a/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor +++ b/basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor @@ -39,7 +39,7 @@ ERROR: splitting-atomic-interval ; : check-split ( live-interval n -- ) check-allocation? get [ [ [ start>> ] dip > [ splitting-too-early ] when ] - [ [ end>> ] dip <= [ splitting-too-late ] when ] + [ [ end>> ] dip < [ splitting-too-late ] when ] [ drop [ end>> ] [ start>> ] bi = [ splitting-atomic-interval ] when ] 2tri ] [ 2drop ] if ; inline diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 11e190d226..60976eb305 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -145,34 +145,24 @@ H{ { vreg 3 } { reg-class float-regs } { start 0 } - { end 1 } - { uses V{ T{ vreg-use f 0 float-rep f } } } - { ranges V{ T{ live-range f 0 1 } } } + { end 2 } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } } } + { ranges V{ T{ live-range f 0 2 } } } { spill-to T{ spill-slot f 8 } } { spill-rep float-rep } } - T{ live-interval - { vreg 3 } - { reg-class float-regs } - { start 20 } - { end 30 } - { uses V{ T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } } - { ranges V{ T{ live-range f 20 30 } } } - { reload-from T{ spill-slot f 8 } } - { reload-rep float-rep } - } + f ] [ T{ live-interval { vreg 3 } { reg-class float-regs } { start 0 } - { end 30 } - { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } } - { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } } - } 10 split-for-spill + { end 5 } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } T{ vreg-use f 5 f float-rep } } } + { ranges V{ T{ live-range f 0 5 } } } + } 5 split-for-spill ] unit-test -! Don't insert reload if first usage is a def [ T{ live-interval { vreg 4 } @@ -189,12 +179,45 @@ H{ { reg-class float-regs } { start 20 } { end 30 } + { uses V{ T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } } + { ranges V{ T{ live-range f 20 30 } } } + { reload-from T{ spill-slot f 12 } } + { reload-rep float-rep } + } +] [ + T{ live-interval + { vreg 4 } + { reg-class float-regs } + { start 0 } + { end 30 } + { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } } + { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } } + } 10 split-for-spill +] unit-test + +! Don't insert reload if first usage is a def +[ + T{ live-interval + { vreg 5 } + { reg-class float-regs } + { start 0 } + { end 1 } + { uses V{ T{ vreg-use f 0 float-rep f } } } + { ranges V{ T{ live-range f 0 1 } } } + { spill-to T{ spill-slot f 16 } } + { spill-rep float-rep } + } + T{ live-interval + { vreg 5 } + { reg-class float-regs } + { start 20 } + { end 30 } { uses V{ T{ vreg-use f 20 float-rep f } T{ vreg-use f 30 f float-rep } } } { ranges V{ T{ live-range f 20 30 } } } } ] [ T{ live-interval - { vreg 4 } + { vreg 5 } { reg-class float-regs } { start 0 } { end 30 } @@ -206,28 +229,28 @@ H{ ! Multiple representations [ T{ live-interval - { vreg 5 } + { vreg 6 } { reg-class float-regs } { start 0 } { end 11 } { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 10 double-rep float-rep } } } { ranges V{ T{ live-range f 0 11 } } } - { spill-to T{ spill-slot f 16 } } + { spill-to T{ spill-slot f 24 } } { spill-rep double-rep } } T{ live-interval - { vreg 5 } + { vreg 6 } { reg-class float-regs } { start 20 } { end 20 } { uses V{ T{ vreg-use f 20 f double-rep } } } { ranges V{ T{ live-range f 20 20 } } } - { reload-from T{ spill-slot f 16 } } + { reload-from T{ spill-slot f 24 } } { reload-rep double-rep } } ] [ T{ live-interval - { vreg 5 } + { vreg 6 } { reg-class float-regs } { start 0 } { end 20 } diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 50efbd43e4..3dd9e5a6db 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -54,6 +54,10 @@ M: live-interval covers? ( insn# live-interval -- ? ) covers? ] if ; +:: find-use ( insn# live-interval -- vreg-use ) + insn# live-interval uses>> [ n>> <=> ] with search nip + dup [ dup n>> insn# = [ drop f ] unless ] when ; + : add-new-range ( from to live-interval -- ) [ ] dip ranges>> push ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 1958c4add1..a927fa8ace 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -276,20 +276,21 @@ CONDITIONAL: ##fixnum-sub %fixnum-sub CONDITIONAL: ##fixnum-mul %fixnum-mul ! FFI +CODEGEN: ##unbox %unbox +CODEGEN: ##store-reg-param %store-reg-param +CODEGEN: ##store-stack-param %store-stack-param +CODEGEN: ##store-return %store-return +CODEGEN: ##store-struct-return %store-struct-return +CODEGEN: ##store-long-long-return %store-long-long-return +CODEGEN: ##prepare-struct-area %prepare-struct-area CODEGEN: ##box %box CODEGEN: ##box-long-long %box-long-long CODEGEN: ##box-large-struct %box-large-struct CODEGEN: ##box-small-struct %box-small-struct -CODEGEN: ##unbox %unbox -CODEGEN: ##unbox-long-long %unbox-long-long -CODEGEN: ##unbox-large-struct %unbox-large-struct -CODEGEN: ##unbox-small-struct %unbox-small-struct -CODEGEN: ##prepare-box-struct %prepare-box-struct -CODEGEN: ##load-param-reg %load-param-reg +CODEGEN: ##save-param-reg %save-param-reg CODEGEN: ##alien-invoke %alien-invoke CODEGEN: ##cleanup %cleanup CODEGEN: ##alien-indirect %alien-indirect -CODEGEN: ##save-param-reg %save-param-reg CODEGEN: ##begin-callback %begin-callback CODEGEN: ##alien-callback %alien-callback CODEGEN: ##end-callback %end-callback diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index ae14e07026..e485cfcb1e 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -534,10 +534,6 @@ M: object immediate-comparand? ( n -- ? ) : immediate-shift-count? ( n -- ? ) 0 cell-bits 1 - between? ; -! What c-type describes the implicit struct return pointer for -! large structs? -HOOK: struct-return-pointer-type cpu ( -- c-type ) - ! Is this structure small enough to be returned in registers? HOOK: return-struct-in-registers? cpu ( c-type -- ? ) @@ -553,15 +549,30 @@ HOOK: dummy-int-params? cpu ( -- ? ) ! If t, all int parameters are shadowed by dummy FP parameters HOOK: dummy-fp-params? cpu ( -- ? ) +! If t, long longs are never passed in param regs +HOOK: long-long-on-stack? cpu ( -- ? ) + +! If t, structs are never passed in param regs +HOOK: struct-on-stack? cpu ( -- ? ) + +! If t, the struct return pointer is never passed in a param reg +HOOK: struct-return-on-stack? cpu ( -- ? ) + ! Call a function to convert a tagged pointer into a value that ! can be passed to a C function, or returned from a callback -HOOK: %unbox cpu ( src n rep func -- ) +HOOK: %unbox cpu ( dst src func rep -- ) -HOOK: %unbox-long-long cpu ( src n func -- ) +HOOK: %store-reg-param cpu ( src reg rep -- ) -HOOK: %unbox-small-struct cpu ( src c-type -- ) +HOOK: %store-stack-param cpu ( src n rep -- ) -HOOK: %unbox-large-struct cpu ( src n c-type -- ) +HOOK: %store-return cpu ( src rep -- ) + +HOOK: %store-struct-return cpu ( src reps -- ) + +HOOK: %store-long-long-return cpu ( src1 src2 -- ) + +HOOK: %prepare-struct-area cpu ( dst -- ) ! Call a function to convert a value into a tagged pointer, ! possibly allocating a bignum, float, or alien instance, @@ -570,25 +581,21 @@ HOOK: %box cpu ( dst n rep func -- ) HOOK: %box-long-long cpu ( dst n func -- ) -HOOK: %prepare-box-struct cpu ( -- ) - HOOK: %box-small-struct cpu ( dst c-type -- ) HOOK: %box-large-struct cpu ( dst n c-type -- ) HOOK: %save-param-reg cpu ( stack reg rep -- ) -HOOK: %load-param-reg cpu ( stack reg rep -- ) - HOOK: %restore-context cpu ( temp1 temp2 -- ) HOOK: %save-context cpu ( temp1 temp2 -- ) HOOK: %alien-invoke cpu ( function library -- ) -HOOK: %cleanup cpu ( params -- ) +HOOK: %cleanup cpu ( n -- ) -M: object %cleanup ( params -- ) drop ; +M: object %cleanup ( n -- ) drop ; HOOK: %alien-indirect cpu ( src -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 3f3276cf09..233f5eb538 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -769,8 +769,6 @@ M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ; M: ppc immediate-store? drop f ; -M: ppc struct-return-pointer-type void* ; - M: ppc return-struct-in-registers? ( c-type -- ? ) c-type return-in-registers?>> ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index bb091a2fe7..68957e0f5f 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -95,17 +95,14 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? ) os { linux netbsd solaris } member? not and or ; -: struct-return@ ( n -- operand ) - [ next-stack@ ] [ stack-frame get params>> local@ ] if* ; - -! On x86, parameters are usually never passed in registers, except with Microsoft's -! "thiscall" and "fastcall" abis +! On x86, parameters are usually never passed in registers, +! except with Microsoft's "thiscall" and "fastcall" abis M: int-regs return-reg drop EAX ; M: float-regs param-regs 2drop { } ; M: int-regs param-regs nip { - { thiscall [ { ECX } ] } + { thiscall [ { ECX } ] } { fastcall [ { ECX EDX } ] } [ drop { } ] } case ; @@ -133,6 +130,26 @@ M: x86.32 %prologue ( n -- ) M: x86.32 %prepare-jump pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ; +:: call-unbox-func ( src func -- ) + EAX src tagged-rep %copy + 4 save-vm-ptr + 0 stack@ EAX MOV + func f %alien-invoke ; + +M:: x86.32 %unbox ( dst src func rep -- ) + src func call-unbox-func + dst rep reg-class-of return-reg rep %copy ; + +M:: x86.32 %store-long-long-return ( src1 src2 n func -- ) + src2 EAX = [ src1 src2 XCHG src2 src1 ] [ src1 src2 ] if :> ( src1 src2 ) + EAX src1 int-rep %copy + EDX src2 int-rep %copy ; + +M:: x86.32 %store-struct-return ( src c-type -- ) + EAX src int-rep %copy + EDX EAX 4 [+] MOV + EAX EAX [] MOV ; + M: stack-params copy-register* drop { @@ -142,8 +159,6 @@ M: stack-params copy-register* M: x86.32 %save-param-reg [ local@ ] 2dip %copy ; -M: x86.32 %load-param-reg [ swap local@ ] dip %copy ; - : (%box) ( n rep -- ) #! If n is f, push the return register onto the stack; we #! are boxing a return value of a C function. If n is an @@ -172,6 +187,9 @@ M:: x86.32 %box-long-long ( dst n func -- ) func f %alien-invoke dst EAX tagged-rep %copy ; +M: x86.32 struct-return@ ( n -- operand ) + [ next-stack@ ] [ stack-frame get params>> local@ ] if* ; + M:: x86.32 %box-large-struct ( dst n c-type -- ) EDX n struct-return@ LEA 8 save-vm-ptr @@ -180,12 +198,6 @@ M:: x86.32 %box-large-struct ( dst n c-type -- ) "from_value_struct" f %alien-invoke dst EAX tagged-rep %copy ; -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 local@ EAX MOV ; - M:: x86.32 %box-small-struct ( dst c-type -- ) #! Box a <= 8-byte struct returned in EAX:EDX. OS X only. 12 save-vm-ptr @@ -195,46 +207,6 @@ M:: x86.32 %box-small-struct ( dst c-type -- ) "from_small_struct" f %alien-invoke dst EAX tagged-rep %copy ; -:: call-unbox-func ( src func -- ) - EAX src tagged-rep %copy - 4 save-vm-ptr - 0 stack@ EAX MOV - func f %alien-invoke ; - -M:: x86.32 %unbox ( src n rep func -- ) - ! If n is f, we're unboxing a return value about to be - ! returned by the callback. Otherwise, we're unboxing - ! a parameter to a C function about to be called. - src func call-unbox-func - ! Store the return value on the C stack - n [ n local@ rep store-return-reg ] when ; - -M:: x86.32 %unbox-long-long ( src n func -- ) - src func call-unbox-func - ! Store the return value on the C stack - n [ - [ local@ EAX MOV ] - [ 4 + local@ EDX MOV ] bi - ] when* ; - -M: x86 %unbox-small-struct ( src size -- ) - [ [ EAX ] dip int-rep %copy ] - [ - heap-size 4 > [ EDX EAX 4 [+] MOV ] when - EAX EAX [] MOV - ] bi* ; - -M:: x86.32 %unbox-large-struct ( src n c-type -- ) - EAX src int-rep %copy - EDX n local@ LEA - 8 stack@ c-type heap-size MOV - 4 stack@ EAX MOV - 0 stack@ EDX MOV - "memcpy" "libc" load-library %alien-invoke ; - -M: x86.32 %alien-indirect ( src -- ) - ?spill-slot CALL ; - M: x86.32 %begin-callback ( -- ) 0 save-vm-ptr 4 stack@ 0 MOV @@ -280,7 +252,7 @@ M:: x86.32 %binary-float-function ( dst src1 src2 func -- ) : funny-large-struct-return? ( params -- ? ) #! MINGW ABI incompatibility disaster [ return>> large-struct? ] - [ abi>> mingw = os windows? not or ] + [ abi>> mingw eq? os windows? not or ] bi and ; : stack-arg-size ( params -- n ) @@ -301,8 +273,8 @@ M: x86.32 stack-cleanup ( params -- n ) [ drop 0 ] } cond ; -M: x86.32 %cleanup ( params -- ) - stack-cleanup [ ESP swap SUB ] unless-zero ; +M: x86.32 %cleanup ( n -- ) + [ ESP swap SUB ] unless-zero ; M:: x86.32 %call-gc ( gc-roots -- ) 4 save-vm-ptr @@ -315,12 +287,10 @@ M: x86.32 dummy-int-params? f ; M: x86.32 dummy-fp-params? f ; -! Dreadful -M: struct-c-type flatten-c-type stack-params (flatten-c-type) ; -M: long-long-type flatten-c-type stack-params (flatten-c-type) ; -M: c-type flatten-c-type dup rep>> int-rep? int-rep stack-params ? (flatten-c-type) ; +M: x86.32 long-long-on-stack? t ; -M: x86.32 struct-return-pointer-type - os linux? void* (stack-value) ? ; +M: x86.32 structs-on-stack? t ; + +M: x86.32 struct-return-on-stack? os linux? not ; check-sse diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 8da9b6ac17..9c42a99096 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -99,6 +99,33 @@ M:: x86.64 %dispatch ( src temp -- ) [ (align-code) ] bi ; +M:: x86.64 %unbox ( dst src func rep -- ) + param-reg-0 src tagged-rep %copy + param-reg-1 %mov-vm-ptr + func f %alien-invoke + dst rep reg-class-of return-reg rep %copy ; + +: with-return-regs ( quot -- ) + [ + V{ RDX RAX } clone int-regs set + V{ XMM1 XMM0 } clone float-regs set + call + ] with-scope ; inline + +: %unbox-struct-field ( rep i -- ) + R11 swap cells [+] swap reg-class-of { + { int-regs [ int-regs get pop swap MOV ] } + { float-regs [ float-regs get pop swap MOVSD ] } + } case ; + +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 + [ + c-type flatten-struct-type + [ %unbox-struct-field ] each-index + ] with-return-regs ; + M: stack-params copy-register* drop { @@ -108,59 +135,9 @@ M: stack-params copy-register* M: x86.64 %save-param-reg [ param@ ] 2dip %copy ; -M: x86.64 %load-param-reg [ swap param@ ] dip %copy ; - -: with-return-regs ( quot -- ) - [ - V{ RDX RAX } clone int-regs set - V{ XMM1 XMM0 } clone float-regs set - call - ] with-scope ; inline - -M:: x86.64 %unbox ( src n rep func -- ) - param-reg-0 src tagged-rep %copy - param-reg-1 %mov-vm-ptr - ! Call the unboxer - func f %alien-invoke - ! Store the return value on the C stack if this is an - ! alien-invoke, otherwise leave it the return register if - ! this is the end of alien-callback - n [ n rep reg-class-of return-reg rep %save-param-reg ] when ; - -: %unbox-struct-field ( rep i -- ) - R11 swap cells [+] swap reg-class-of { - { int-regs [ int-regs get pop swap MOV ] } - { float-regs [ float-regs get pop swap MOVSD ] } - } case ; - -M:: x86.64 %unbox-small-struct ( src c-type -- ) - ! Move src to R11 so that we don't clobber it. - R11 src int-rep %copy - [ - c-type flatten-struct-type - [ %unbox-struct-field ] each-index - ] with-return-regs ; - -M:: x86.64 %unbox-large-struct ( src n c-type -- ) - param-reg-1 src int-rep %copy - param-reg-0 n param@ LEA - param-reg-2 c-type heap-size MOV - "memcpy" "libc" load-library %alien-invoke ; - -: load-return-value ( rep -- ) - [ [ 0 ] dip reg-class-of cdecl param-reg ] - [ reg-class-of return-reg ] - [ ] - tri %copy ; - M:: x86.64 %box ( dst n rep func -- ) - n [ - n - 0 rep reg-class-of cdecl param-reg - rep %load-param-reg - ] [ - rep load-return-value - ] if + 0 rep reg-class-of cdecl param-reg + n [ n param@ ] [ rep reg-class-of return-reg ] if rep %copy rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr func f %alien-invoke dst RAX tagged-rep %copy ; @@ -185,7 +162,7 @@ M:: x86.64 %box-small-struct ( dst c-type -- ) dst RAX tagged-rep %copy ] with-return-regs ; -: struct-return@ ( n -- operand ) +M: x86.64 struct-return@ ( n -- operand ) [ stack-frame get params>> ] unless* param@ ; M:: x86.64 %box-large-struct ( dst n c-type -- ) @@ -198,20 +175,11 @@ M:: x86.64 %box-large-struct ( dst n c-type -- ) "from_value_struct" f %alien-invoke dst RAX tagged-rep %copy ; -M: x86.64 %prepare-box-struct ( -- ) - ! Compute target address for value struct return - RAX f struct-return@ LEA - ! Store it as the first parameter - 0 param@ RAX MOV ; - M: x86.64 %alien-invoke R11 0 MOV rc-absolute-cell rel-dlsym R11 CALL ; -M: x86.64 %alien-indirect ( src -- ) - ?spill-slot CALL ; - M: x86.64 %begin-callback ( -- ) param-reg-0 %mov-vm-ptr param-reg-1 0 MOV @@ -249,7 +217,11 @@ M:: x86.64 %call-gc ( gc-roots -- ) param-reg-1 %mov-vm-ptr "inline_gc" f %alien-invoke ; -M: x86.64 struct-return-pointer-type void* ; +M: x86.64 long-long-on-stack? f ; + +M: x86.64 struct-on-stack? f ; + +M: x86.64 struct-return-on-stack? f ; ! The result of reading 4 bytes from memory is a fixnum on ! x86-64. diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 1c3ff57a34..bdf325a826 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -1443,10 +1443,31 @@ M: x86.64 %scalar>integer ( dst src rep -- ) } case ; M: x86 %vector>scalar %copy ; + M: x86 %scalar>vector %copy ; -M:: x86 %spill ( src rep dst -- ) dst src rep %copy ; -M:: x86 %reload ( dst rep src -- ) dst src rep %copy ; +M:: x86 %spill ( src rep dst -- ) + dst src rep %copy ; + +M:: x86 %reload ( dst rep src -- ) + dst src rep %copy ; + +M:: x86 %store-reg-param ( src reg rep -- ) + reg src rep %copy ; + +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 -- ) + f struct-return@ LEA ; + +M: x86 %alien-indirect ( src -- ) + ?spill-slot CALL ; M: x86 %loop-entry 16 alignment [ NOP ] times ; diff --git a/vm/contexts.hpp b/vm/contexts.hpp index 582fab173f..80dbf14740 100644 --- a/vm/contexts.hpp +++ b/vm/contexts.hpp @@ -36,6 +36,9 @@ struct context { set-context-object primitives */ cell context_objects[context_object_count]; + /* temporary area used by FFI code generation */ + s64 long_long_return; + context(cell datastack_size, cell retainstack_size, cell callstack_size); ~context(); diff --git a/vm/math.cpp b/vm/math.cpp index e64db2690e..a418cbff1b 100755 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -491,9 +491,10 @@ s64 factor_vm::to_signed_8(cell obj) } } -VM_C_API s64 to_signed_8(cell obj, factor_vm *parent) +VM_C_API s64 *to_signed_8(cell obj, factor_vm *parent) { - return parent->to_signed_8(obj); + parent->ctx->long_long_return = parent->to_signed_8(obj); + return &parent->ctx->long_long_return; } cell factor_vm::from_unsigned_8(u64 n) @@ -524,9 +525,10 @@ u64 factor_vm::to_unsigned_8(cell obj) } } -VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent) +VM_C_API s64 *to_unsigned_8(cell obj, factor_vm *parent) { - return parent->to_unsigned_8(obj); + parent->ctx->long_long_return = parent->to_unsigned_8(obj); + return &parent->ctx->long_long_return; } VM_C_API cell from_float(float flo, factor_vm *parent)