From a228e575a5881235eabbd01c542fa378340aacab Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 7 May 2010 17:16:28 -0700 Subject: [PATCH 01/21] cdua.devices: remove redundant init-cuda calls --- extra/cuda/devices/devices.factor | 8 -------- 1 file changed, 8 deletions(-) diff --git a/extra/cuda/devices/devices.factor b/extra/cuda/devices/devices.factor index 8b29295a0b..e5f72f50d6 100644 --- a/extra/cuda/devices/devices.factor +++ b/extra/cuda/devices/devices.factor @@ -7,11 +7,9 @@ sequences ; IN: cuda.devices : #cuda-devices ( -- n ) - init-cuda int [ cuDeviceGetCount cuda-error ] keep *int ; : n>cuda-device ( n -- device ) - init-cuda [ CUdevice ] dip [ cuDeviceGet cuda-error ] 2keep drop *int ; : enumerate-cuda-devices ( -- devices ) @@ -21,7 +19,6 @@ IN: cuda.devices [ enumerate-cuda-devices ] dip '[ _ with-cuda ] each ; inline : cuda-device-properties ( n -- properties ) - init-cuda [ CUdevprop ] dip [ cuDeviceGetProperties cuda-error ] 2keep drop CUdevprop memory>struct ; @@ -30,31 +27,26 @@ IN: cuda.devices enumerate-cuda-devices [ dup cuda-device-properties ] { } map>assoc ; : cuda-device-name ( n -- string ) - init-cuda [ 256 [ ] keep ] dip [ cuDeviceGetName cuda-error ] [ 2drop utf8 alien>string ] 3bi ; : cuda-device-capability ( n -- pair ) - init-cuda [ int int ] dip [ cuDeviceComputeCapability cuda-error ] [ drop [ *int ] bi@ ] 3bi 2array ; : cuda-device-memory ( n -- bytes ) - init-cuda [ uint ] dip [ cuDeviceTotalMem cuda-error ] [ drop *uint ] 2bi ; : cuda-device-attribute ( attribute n -- n ) - init-cuda [ int ] 2dip [ cuDeviceGetAttribute cuda-error ] [ 2drop *int ] 3bi ; : cuda-device. ( n -- ) - init-cuda { [ "Device: " write number>string print ] [ "Name: " write cuda-device-name print ] From 097100cb124c9f6675bec2daf537abe181197bf7 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 7 May 2010 17:18:08 -0700 Subject: [PATCH 02/21] cuda.utils: foo ... foo memory>struct == foo --- extra/cuda/utils/utils.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/cuda/utils/utils.factor b/extra/cuda/utils/utils.factor index eef205992f..a85a0b35e9 100644 --- a/extra/cuda/utils/utils.factor +++ b/extra/cuda/utils/utils.factor @@ -92,3 +92,5 @@ ERROR: throw-cuda-error n ; : function-shared-size ( n -- ) [ cuda-function get ] dip cuFuncSetSharedSize cuda-error ; + +: distribute-jobs ( job-count per-job-shared -- grid-size block-size per-block-shared ) From f26a5836e63d9937c632185443e436976dcfc33c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 7 May 2010 18:02:42 -0700 Subject: [PATCH 03/21] cuda.devices: "distribute-jobs" utility word that determines grid and block size for a job based on per-thread shared memory requirements and max block size --- extra/cuda/cuda.factor | 14 ++++++------ extra/cuda/devices/devices-tests.factor | 13 +++++++++++ extra/cuda/devices/devices.factor | 30 +++++++++++++++++++------ extra/cuda/utils/utils.factor | 6 ++--- 4 files changed, 45 insertions(+), 18 deletions(-) create mode 100644 extra/cuda/devices/devices-tests.factor diff --git a/extra/cuda/cuda.factor b/extra/cuda/cuda.factor index 1b144632fb..dd3f5b8f9e 100644 --- a/extra/cuda/cuda.factor +++ b/extra/cuda/cuda.factor @@ -7,7 +7,7 @@ destructors fry init io io.backend io.encodings.string io.encodings.utf8 kernel lexer locals macros math math.parser namespaces nested-comments opengl.gl.extensions parser prettyprint quotations sequences words cuda.libraries ; -QUALIFIED-WITH: alien.c-types a +QUALIFIED-WITH: alien.c-types c IN: cuda TUPLE: launcher @@ -41,11 +41,11 @@ dim-grid dim-block shared-size stream ; : c-type>cuda-setter ( c-type -- n cuda-type ) { - { [ dup a:int = ] [ drop 4 [ cuda-int* ] ] } - { [ dup a:uint = ] [ drop 4 [ cuda-int* ] ] } - { [ dup a:float = ] [ drop 4 [ cuda-float* ] ] } - { [ dup a:pointer? ] [ drop 4 [ cuda-int* ] ] } - { [ dup a:void* = ] [ drop 4 [ cuda-int* ] ] } + { [ dup c:int = ] [ drop 4 [ cuda-int* ] ] } + { [ dup c:uint = ] [ drop 4 [ cuda-int* ] ] } + { [ dup c:float = ] [ drop 4 [ cuda-float* ] ] } + { [ dup c:pointer? ] [ drop 4 [ cuda-int* ] ] } + { [ dup c:void* = ] [ drop 4 [ cuda-int* ] ] } } cond ; _ with-cuda ] each ; inline : cuda-device-properties ( n -- properties ) - [ CUdevprop ] dip - [ cuDeviceGetProperties cuda-error ] 2keep drop - CUdevprop memory>struct ; + [ CUdevprop ] dip + [ cuDeviceGetProperties cuda-error ] 2keep drop ; : cuda-devices ( -- assoc ) enumerate-cuda-devices [ dup cuda-device-properties ] { } map>assoc ; @@ -68,3 +67,20 @@ IN: cuda.devices "CUDA Version: " write cuda-version number>string print nl #cuda-devices iota [ nl ] [ cuda-device. ] interleave ; +: up/i ( x y -- z ) + [ 1 - + ] keep /i ; inline + +:: (distribute-jobs) ( job-count per-job-shared max-shared-size max-block-size + -- grid-size block-size per-block-shared ) + per-job-shared [ max-block-size ] [ max-shared-size swap /i max-block-size min ] if-zero + job-count min :> job-max-block-size + job-count job-max-block-size up/i :> grid-size + job-count grid-size up/i :> block-size + block-size per-job-shared * :> per-block-shared + + grid-size block-size per-block-shared ; inline + +: distribute-jobs ( job-count per-job-shared -- grid-size block-size per-block-shared ) + cuda-device get cuda-device-properties + [ sharedMemPerBlock>> ] [ maxThreadsDim>> ] bi + (distribute-jobs) ; inline diff --git a/extra/cuda/utils/utils.factor b/extra/cuda/utils/utils.factor index a85a0b35e9..269ebbe401 100644 --- a/extra/cuda/utils/utils.factor +++ b/extra/cuda/utils/utils.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2010 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.data alien.strings arrays -assocs byte-arrays classes.struct combinators cuda.ffi io -io.backend io.encodings.utf8 kernel math.parser namespaces +assocs byte-arrays classes.struct combinators cuda.devices cuda.ffi +io io.backend io.encodings.utf8 kernel math.parser namespaces prettyprint sequences ; IN: cuda.utils @@ -92,5 +92,3 @@ ERROR: throw-cuda-error n ; : function-shared-size ( n -- ) [ cuda-function get ] dip cuFuncSetSharedSize cuda-error ; - -: distribute-jobs ( job-count per-job-shared -- grid-size block-size per-block-shared ) From 5a980b58cb37ea4bcda6f2815de45dbc13a98044 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 7 May 2010 18:03:30 -0700 Subject: [PATCH 04/21] remove cuda.constants; it's better to get those values from device-properties --- extra/cuda/constants/constants.factor | 4 ---- 1 file changed, 4 deletions(-) delete mode 100644 extra/cuda/constants/constants.factor diff --git a/extra/cuda/constants/constants.factor b/extra/cuda/constants/constants.factor deleted file mode 100644 index d66cabe444..0000000000 --- a/extra/cuda/constants/constants.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: cuda.constants - -CONSTANT: cuda-shared-size 16384 -CONSTANT: cuda-warp-size 32 From 6d41ea32f58be873a74acd8e2b1cfa897865da24 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 7 May 2010 18:09:21 -0700 Subject: [PATCH 05/21] cuda.devices: have distribute-jobs construct a launcher with the calculated grid-dim, block-dim, and shared-size --- extra/cuda/devices/devices.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/cuda/devices/devices.factor b/extra/cuda/devices/devices.factor index 17e098c8df..d909e9ab5c 100644 --- a/extra/cuda/devices/devices.factor +++ b/extra/cuda/devices/devices.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.data alien.strings arrays assocs byte-arrays classes.struct combinators cuda cuda.ffi -cuda.utils fry io io.encodings.utf8 kernel locals math -math.order math.parser namespaces prettyprint sequences ; +cuda.syntax cuda.utils fry io io.encodings.utf8 kernel locals +math math.order math.parser namespaces prettyprint sequences ; IN: cuda.devices : #cuda-devices ( -- n ) @@ -80,7 +80,7 @@ IN: cuda.devices grid-size block-size per-block-shared ; inline -: distribute-jobs ( job-count per-job-shared -- grid-size block-size per-block-shared ) +: distribute-jobs ( job-count per-job-shared -- launcher ) cuda-device get cuda-device-properties [ sharedMemPerBlock>> ] [ maxThreadsDim>> ] bi - (distribute-jobs) ; inline + (distribute-jobs) 3<<< ; inline From 077cd0397b3a992435f305d75da18de78c689572 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 7 May 2010 18:15:37 -0700 Subject: [PATCH 06/21] cuda.devices: fix distribute-jobs to look only at width of maxThreadsDim --- extra/cuda/devices/devices.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/cuda/devices/devices.factor b/extra/cuda/devices/devices.factor index d909e9ab5c..7ad7b32c8d 100644 --- a/extra/cuda/devices/devices.factor +++ b/extra/cuda/devices/devices.factor @@ -82,5 +82,5 @@ IN: cuda.devices : distribute-jobs ( job-count per-job-shared -- launcher ) cuda-device get cuda-device-properties - [ sharedMemPerBlock>> ] [ maxThreadsDim>> ] bi + [ sharedMemPerBlock>> ] [ maxThreadsDim>> first ] bi (distribute-jobs) 3<<< ; inline From 6d30ce485c9117e131b59b4a8ded14b90e4be7ee Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 10 May 2010 15:06:15 -0700 Subject: [PATCH 07/21] cuda.utils: add "sync-context" word --- extra/cuda/utils/utils.factor | 41 +++++++++++++++++++---------------- 1 file changed, 22 insertions(+), 19 deletions(-) diff --git a/extra/cuda/utils/utils.factor b/extra/cuda/utils/utils.factor index 269ebbe401..2f5b03642c 100644 --- a/extra/cuda/utils/utils.factor +++ b/extra/cuda/utils/utils.factor @@ -21,7 +21,7 @@ ERROR: throw-cuda-error n ; dup CUDA_SUCCESS = [ drop ] [ throw-cuda-error ] if ; : init-cuda ( -- ) - 0 cuInit cuda-error ; + 0 cuInit cuda-error ; inline : cuda-version ( -- n ) int [ cuDriverGetVersion cuda-error ] keep *int ; @@ -40,55 +40,58 @@ ERROR: throw-cuda-error n ; : create-context ( flags device -- context ) [ CUcontext ] 2dip - [ cuCtxCreate cuda-error ] 3keep 2drop *void* ; + [ cuCtxCreate cuda-error ] 3keep 2drop *void* ; inline -: destroy-context ( context -- ) cuCtxDestroy cuda-error ; +: sync-context ( -- ) + cuCtxSynchronize cuda-error ; inline -: launch-function* ( function -- ) cuLaunch cuda-error ; +: destroy-context ( context -- ) cuCtxDestroy cuda-error ; inline -: launch-function ( -- ) cuda-function get cuLaunch cuda-error ; +: launch-function* ( function -- ) cuLaunch cuda-error ; inline + +: launch-function ( -- ) cuda-function get cuLaunch cuda-error ; inline : cuda-int* ( function offset value -- ) - cuParamSeti cuda-error ; + cuParamSeti cuda-error ; inline : cuda-int ( offset value -- ) - [ cuda-function get ] 2dip cuda-int* ; + [ cuda-function get ] 2dip cuda-int* ; inline : cuda-float* ( function offset value -- ) - cuParamSetf cuda-error ; + cuParamSetf cuda-error ; inline : cuda-float ( offset value -- ) - [ cuda-function get ] 2dip cuda-float* ; + [ cuda-function get ] 2dip cuda-float* ; inline : cuda-vector* ( function offset ptr n -- ) - cuParamSetv cuda-error ; + cuParamSetv cuda-error ; inline : cuda-vector ( offset ptr n -- ) - [ cuda-function get ] 3dip cuda-vector* ; + [ cuda-function get ] 3dip cuda-vector* ; inline : param-size* ( function n -- ) - cuParamSetSize cuda-error ; + cuParamSetSize cuda-error ; inline : param-size ( n -- ) - [ cuda-function get ] dip param-size* ; + [ cuda-function get ] dip param-size* ; inline : launch-function-grid* ( function width height -- ) - cuLaunchGrid cuda-error ; + cuLaunchGrid cuda-error ; inline : launch-function-grid ( width height -- ) [ cuda-function get ] 2dip - cuLaunchGrid cuda-error ; + cuLaunchGrid cuda-error ; inline : function-block-shape* ( function x y z -- ) - cuFuncSetBlockShape cuda-error ; + cuFuncSetBlockShape cuda-error ; inline : function-block-shape ( x y z -- ) [ cuda-function get ] 3dip - cuFuncSetBlockShape cuda-error ; + cuFuncSetBlockShape cuda-error ; inline : function-shared-size* ( function n -- ) - cuFuncSetSharedSize cuda-error ; + cuFuncSetSharedSize cuda-error ; inline : function-shared-size ( n -- ) [ cuda-function get ] dip - cuFuncSetSharedSize cuda-error ; + cuFuncSetSharedSize cuda-error ; inline From 423f9c607aca3daf88bc996f0bb0cbc70bfe87e4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 10 May 2010 17:50:10 -0500 Subject: [PATCH 08/21] cpu.ppc: fixes --- basis/cpu/ppc/ppc.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 3d2937f9b1..3f3276cf09 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -3,8 +3,8 @@ USING: accessors assocs sequences kernel combinators classes.algebra byte-arrays make math math.order math.ranges system namespaces locals layouts words alien alien.accessors -alien.c-types alien.complex alien.data literals cpu.architecture -cpu.ppc.assembler cpu.ppc.assembler.backend +alien.c-types alien.complex alien.data alien.libraries +literals cpu.architecture cpu.ppc.assembler cpu.ppc.assembler.backend compiler.cfg.registers compiler.cfg.instructions compiler.cfg.comparisons compiler.codegen.fixup compiler.cfg.intrinsics compiler.cfg.stack-frame @@ -681,13 +681,13 @@ GENERIC: load-param ( reg src -- ) M: integer load-param int-rep %copy ; -M: spill-slot load-param n>> spill@ LWZ ; +M: spill-slot load-param [ 1 ] dip n>> spill@ LWZ ; GENERIC: store-param ( reg dst -- ) M: integer store-param swap int-rep %copy ; -M: spill-slot store-param n>> spill@ STW ; +M: spill-slot store-param [ 1 ] dip n>> spill@ STW ; :: call-unbox-func ( src func -- ) 3 src load-param @@ -710,7 +710,7 @@ M:: ppc %unbox-long-long ( src n func -- ) M:: ppc %unbox-large-struct ( src n c-type -- ) 4 src load-param 3 1 n local@ ADDI - heap-size 5 LI + c-type heap-size 5 LI "memcpy" "libc" load-library %alien-invoke ; M:: ppc %box ( dst n rep func -- ) @@ -724,6 +724,7 @@ M:: ppc %box-long-long ( dst n func -- ) 3 1 n local@ LWZ 4 1 n cell + local@ LWZ ] when + 5 %load-vm-addr func f %alien-invoke 3 dst store-param ; From d1e2554ebf5e516291a1974dd5907c27d3f93b6b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 10 May 2010 20:50:28 -0400 Subject: [PATCH 09/21] cuda.utils: fix load error --- extra/cuda/cuda.factor | 4 ++-- extra/cuda/utils/utils.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/cuda/cuda.factor b/extra/cuda/cuda.factor index dd3f5b8f9e..667b3726c2 100644 --- a/extra/cuda/cuda.factor +++ b/extra/cuda/cuda.factor @@ -5,8 +5,8 @@ alien.syntax arrays assocs byte-arrays classes.struct combinators continuations cuda.ffi cuda.memory cuda.utils destructors fry init io io.backend io.encodings.string io.encodings.utf8 kernel lexer locals macros math math.parser -namespaces nested-comments opengl.gl.extensions parser -prettyprint quotations sequences words cuda.libraries ; +namespaces opengl.gl.extensions parser prettyprint quotations +sequences words cuda.libraries ; QUALIFIED-WITH: alien.c-types c IN: cuda diff --git a/extra/cuda/utils/utils.factor b/extra/cuda/utils/utils.factor index 2f5b03642c..f329313ceb 100644 --- a/extra/cuda/utils/utils.factor +++ b/extra/cuda/utils/utils.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2010 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.data alien.strings arrays -assocs byte-arrays classes.struct combinators cuda.devices cuda.ffi +assocs byte-arrays classes.struct combinators cuda.ffi io io.backend io.encodings.utf8 kernel math.parser namespaces prettyprint sequences ; IN: cuda.utils From eb802208d1af191378a213068ead625b4b441ef1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 May 2010 19:11:31 -0400 Subject: [PATCH 10/21] FFI rewrite part 4: parameter and return value unboxing redesign --- basis/classes/struct/struct.factor | 8 +- basis/compiler/alien/alien.factor | 6 +- basis/compiler/cfg/builder/alien/alien.factor | 211 +++++++++--------- .../cfg/builder/alien/params/authors.txt | 1 + .../cfg/builder/alien/params/params.factor | 49 ++++ .../cfg/instructions/instructions.factor | 59 ++--- .../linear-scan/allocation/allocation.factor | 24 +- .../allocation/splitting/splitting.factor | 2 +- .../cfg/linear-scan/linear-scan-tests.factor | 71 ++++-- .../live-intervals/live-intervals.factor | 4 + basis/compiler/codegen/codegen.factor | 15 +- basis/cpu/architecture/architecture.factor | 35 +-- basis/cpu/ppc/ppc.factor | 2 - basis/cpu/x86/32/32.factor | 96 +++----- basis/cpu/x86/64/64.factor | 98 +++----- basis/cpu/x86/x86.factor | 25 ++- vm/contexts.hpp | 3 + vm/math.cpp | 10 +- 18 files changed, 379 insertions(+), 340 deletions(-) create mode 100644 basis/compiler/cfg/builder/alien/params/authors.txt create mode 100644 basis/compiler/cfg/builder/alien/params/params.factor 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) From 7d62376e249e600387de939d1866d6124562cca3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 May 2010 19:29:50 -0400 Subject: [PATCH 11/21] vm: fix compile error --- vm/math.hpp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vm/math.hpp b/vm/math.hpp index d78ae54010..c2444b98f9 100644 --- a/vm/math.hpp +++ b/vm/math.hpp @@ -90,8 +90,8 @@ VM_C_API cell from_unsigned_cell(cell integer, factor_vm *vm); VM_C_API cell from_signed_8(s64 n, factor_vm *vm); VM_C_API cell from_unsigned_8(u64 n, factor_vm *vm); -VM_C_API s64 to_signed_8(cell obj, factor_vm *vm); -VM_C_API u64 to_unsigned_8(cell obj, factor_vm *vm); +VM_C_API s64 *to_signed_8(cell obj, factor_vm *vm); +VM_C_API s64 *to_unsigned_8(cell obj, factor_vm *vm); VM_C_API fixnum to_fixnum(cell tagged, factor_vm *vm); VM_C_API cell to_cell(cell tagged, factor_vm *vm); From ee0640f1764e6ac1ad907ad3f35df08e90716063 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 May 2010 22:26:18 -0400 Subject: [PATCH 12/21] Move flatten-c-type to death row so that it can be executed in part 5 --- basis/alien/arrays/arrays.factor | 4 -- basis/alien/c-types/c-types.factor | 17 +------- basis/classes/struct/struct.factor | 7 ++-- basis/compiler/cfg/builder/alien/alien.factor | 17 ++++++-- basis/cpu/architecture/architecture.factor | 3 -- basis/cpu/x86/64/64.factor | 39 +++++++++---------- basis/cpu/x86/64/unix/unix.factor | 3 +- 7 files changed, 39 insertions(+), 51 deletions(-) diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor index bf87cfd9f1..a58549627c 100644 --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -26,8 +26,6 @@ M: array base-type drop void* base-type ; M: array stack-size drop void* stack-size ; -M: array flatten-c-type drop void* flatten-c-type ; - PREDICATE: string-type < pair first2 [ c-string = ] [ word? ] bi* and ; @@ -49,8 +47,6 @@ M: string-type stack-size drop void* stack-size ; M: string-type c-type-rep drop int-rep ; -M: string-type flatten-c-type drop void* flatten-c-type ; - M: string-type c-type-boxer-quot second dup binary = [ drop void* c-type-boxer-quot ] diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index d916ce9dec..af9ef4dc16 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -127,17 +127,6 @@ GENERIC: stack-size ( name -- size ) M: c-type stack-size size>> cell align ; -: (flatten-c-type) ( type rep -- seq ) - [ stack-size cell /i ] dip ; inline - -GENERIC: flatten-c-type ( type -- reps ) - -M: c-type flatten-c-type rep>> 1array ; -M: c-type-name flatten-c-type c-type flatten-c-type ; - -: flatten-c-types ( types -- reps ) - [ flatten-c-type ] map concat ; - MIXIN: value-type : c-getter ( name -- quot ) @@ -165,8 +154,7 @@ PROTOCOL: c-type-protocol c-type-align-first base-type heap-size - stack-size - flatten-c-type ; + stack-size ; CONSULT: c-type-protocol c-type-name c-type ; @@ -185,9 +173,6 @@ TUPLE: long-long-type < c-type ; : ( -- c-type ) long-long-type new ; -M: long-long-type flatten-c-type - int-rep (flatten-c-type) ; - : define-deref ( c-type -- ) [ name>> CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi (( c-ptr -- value )) define-inline ; diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index e0a168cb7d..d8835c1dca 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -171,11 +171,10 @@ M: struct-c-type base-type ; M: struct-c-type stack-size dup value-struct? [ heap-size cell align ] [ drop cell ] if ; -HOOK: flatten-struct-type cpu ( type -- reps ) +HOOK: flatten-struct-type cpu ( type -- pairs ) -M: object flatten-struct-type int-rep (flatten-c-type) ; - -M: struct-c-type flatten-c-type flatten-struct-type ; +M: object flatten-struct-type + stack-size cell /i { int-rep f } ; M: struct-c-type c-struct? drop t ; diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index 6544d656fa..6f12a390d4 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -37,9 +37,9 @@ 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 + [| pair i | + src i cells pair first f ^^load-memory-imm + pair first2 3array ] map-index ] [ { { src int-rep f } } ] if ; @@ -222,6 +222,17 @@ M: struct-c-type box-parameter rep dup reg-class-of reg-class-full? [ alloc-stack-param stack-params ] [ [ next-reg-param ] keep ] if ; +GENERIC: flatten-c-type ( type -- reps ) + +M: struct-c-type flatten-c-type + flatten-struct-type [ first2 [ drop stack-params ] when ] map ; +M: long-long-type flatten-c-type drop { int-rep int-rep } ; +M: c-type flatten-c-type rep>> 1array ; +M: object flatten-c-type base-type flatten-c-type ; + +: flatten-c-types ( types -- reps ) + [ flatten-c-type ] map concat ; + : (registers>objects) ( params -- ) [ 0 ] dip alien-parameters flatten-c-types [ [ alloc-parameter ##save-param-reg ] diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index e485cfcb1e..2d9f845c57 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -552,9 +552,6 @@ 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 ( -- ? ) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 9c42a99096..3721c17cf4 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel math namespaces make sequences system layouts alien alien.c-types alien.accessors alien.libraries -slots splitting assocs combinators locals compiler.constants +slots splitting assocs combinators fry locals compiler.constants classes.struct compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame @@ -112,7 +112,13 @@ M:: x86.64 %unbox ( dst src func rep -- ) call ] with-scope ; inline -: %unbox-struct-field ( rep i -- ) +: each-struct-component ( c-type quot -- ) + '[ + flatten-struct-type + [ [ first ] dip @ ] each-index + ] with-return-regs ; inline + +: %unbox-struct-component ( 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 ] } @@ -121,10 +127,7 @@ M:: x86.64 %unbox ( dst src func rep -- ) 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 ; + c-type [ %unbox-struct-component ] each-struct-component ; M: stack-params copy-register* drop @@ -142,25 +145,23 @@ M:: x86.64 %box ( dst n rep func -- ) func f %alien-invoke dst RAX tagged-rep %copy ; -: box-struct-field@ ( i -- operand ) 1 + cells param@ ; +: box-struct-component@ ( i -- operand ) 1 + cells param@ ; -: %box-struct-field ( rep i -- ) - box-struct-field@ swap reg-class-of { +: %box-struct-component ( rep i -- ) + box-struct-component@ swap reg-class-of { { int-regs [ int-regs get pop MOV ] } { float-regs [ float-regs get pop MOVSD ] } } case ; M:: x86.64 %box-small-struct ( dst c-type -- ) #! Box a <= 16-byte struct. - [ - c-type flatten-struct-type [ %box-struct-field ] each-index - param-reg-2 c-type heap-size MOV - param-reg-0 0 box-struct-field@ MOV - param-reg-1 1 box-struct-field@ MOV - param-reg-3 %mov-vm-ptr - "from_small_struct" f %alien-invoke - dst RAX tagged-rep %copy - ] with-return-regs ; + c-type [ %box-struct-component ] each-struct-component + param-reg-2 c-type heap-size MOV + param-reg-0 0 box-struct-component@ MOV + param-reg-1 1 box-struct-component@ MOV + param-reg-3 %mov-vm-ptr + "from_small_struct" f %alien-invoke + dst RAX tagged-rep %copy ; M: x86.64 struct-return@ ( n -- operand ) [ stack-frame get params>> ] unless* param@ ; @@ -219,8 +220,6 @@ M:: x86.64 %call-gc ( gc-roots -- ) 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 diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index 4e81e8ce13..a5a1cbcc50 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -28,10 +28,11 @@ M: x86.64 reserved-stack-space 0 ; struct-types&offset split-struct [ [ c-type c-type-rep reg-class-of ] map int-regs swap member? int-rep double-rep ? + f 2array ] map ; : flatten-large-struct ( c-type -- seq ) - stack-params (flatten-c-type) ; + stack-size cell /i { int-rep t } ; ; M: x86.64 flatten-struct-type ( c-type -- seq ) dup heap-size 16 > From 1c76c87c5cade4df365da2e83737df46ff434423 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 May 2010 22:29:46 -0400 Subject: [PATCH 13/21] cpu.x86.64: fix typo --- basis/cpu/x86/64/unix/unix.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/64/unix/unix.factor b/basis/cpu/x86/64/unix/unix.factor index a5a1cbcc50..c7b8d4017a 100644 --- a/basis/cpu/x86/64/unix/unix.factor +++ b/basis/cpu/x86/64/unix/unix.factor @@ -32,7 +32,7 @@ M: x86.64 reserved-stack-space 0 ; ] map ; : flatten-large-struct ( c-type -- seq ) - stack-size cell /i { int-rep t } ; ; + stack-size cell /i { int-rep t } ; M: x86.64 flatten-struct-type ( c-type -- seq ) dup heap-size 16 > From 0cde5c8fb54f2e523513ddc3a7f7096e12196dec Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 May 2010 23:23:41 -0400 Subject: [PATCH 14/21] Eliminate compiler.alien --- basis/alien/c-types/c-types.factor | 9 -- basis/alien/syntax/syntax-docs.factor | 4 - basis/classes/struct/struct.factor | 7 +- basis/cocoa/messages/messages.factor | 2 +- basis/compiler/alien/alien.factor | 13 -- basis/compiler/alien/summary.txt | 1 - basis/compiler/cfg/builder/alien/alien.factor | 129 ++++++++++-------- basis/compiler/cfg/builder/builder.factor | 3 +- 8 files changed, 78 insertions(+), 90 deletions(-) delete mode 100644 basis/compiler/alien/alien.factor delete mode 100644 basis/compiler/alien/summary.txt diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index af9ef4dc16..03c35d6251 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -66,15 +66,6 @@ M: word c-type dup "c-type" word-prop resolve-typedef [ ] [ no-c-type ] ?if ; -GENERIC: c-struct? ( c-type -- ? ) - -M: object c-struct? drop f ; - -M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ; - -! These words being foldable means that words need to be -! recompiled if a C type is redefined. Even so, folding the -! size facilitates some optimizations. GENERIC: c-type-class ( name -- class ) M: abstract-c-type c-type-class class>> ; diff --git a/basis/alien/syntax/syntax-docs.factor b/basis/alien/syntax/syntax-docs.factor index c960984d53..c7ff228ab2 100644 --- a/basis/alien/syntax/syntax-docs.factor +++ b/basis/alien/syntax/syntax-docs.factor @@ -119,10 +119,6 @@ HELP: typedef { POSTPONE: TYPEDEF: typedef } related-words -HELP: c-struct? -{ $values { "c-type" "a C type" } { "?" "a boolean" } } -{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ; - HELP: C-GLOBAL: { $syntax "C-GLOBAL: type name" } { $values { "type" "a C type" } { "name" "a C global variable name" } } diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index d8835c1dca..37cea6b9f2 100644 --- a/basis/classes/struct/struct.factor +++ b/basis/classes/struct/struct.factor @@ -176,7 +176,12 @@ HOOK: flatten-struct-type cpu ( type -- pairs ) M: object flatten-struct-type stack-size cell /i { int-rep f } ; -M: struct-c-type c-struct? drop t ; +: large-struct? ( type -- ? ) + { + { [ dup void? ] [ drop f ] } + { [ dup base-type struct-c-type? not ] [ drop f ] } + [ return-struct-in-registers? not ] + } cond ; > - swap return>> large-struct? - [ struct-return-on-stack? (stack-value) void* ? prefix ] when ; diff --git a/basis/compiler/alien/summary.txt b/basis/compiler/alien/summary.txt deleted file mode 100644 index 5fc715b478..0000000000 --- a/basis/compiler/alien/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Common code used for analysis and code generation of alien bindings diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index 6f12a390d4..7f42bdf322 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -1,10 +1,10 @@ ! 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 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 +combinators combinators.short-circuit fry make sequences locals +alien alien.private alien.strings alien.c-types alien.libraries +classes.struct namespaces kernel strings libc quotations +cpu.architecture compiler.utilities compiler.tree compiler.cfg compiler.cfg.builder compiler.cfg.builder.alien.params compiler.cfg.builder.blocks compiler.cfg.instructions compiler.cfg.stack-frame compiler.cfg.stacks @@ -65,9 +65,9 @@ M:: struct-c-type unbox-parameter ( src c-type -- ) : (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. + ! ##store-stack-param instructions come first. This ensures + ! that no registers are used after the ##store-reg-param + ! instructions. [ first3 [ dup reg-class-of reg-class-full? ] dip or [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ] @@ -75,15 +75,13 @@ M:: struct-c-type unbox-parameter ( src c-type -- ) 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. +: objects>registers ( params -- stack-size ) [ abi>> ] [ parameters>> ] [ return>> ] tri '[ _ unbox-parameters _ prepare-struct-area (objects>registers) + stack-params get ] with-param-regs ; GENERIC: box-return ( c-type -- dst ) @@ -94,11 +92,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 ; + dup return-struct-in-registers? + [ ^^box-small-struct ] [ [ f ] dip ^^box-large-struct ] if ; : box-return* ( node -- ) return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ; @@ -130,62 +126,66 @@ M: array dlsym-valid? '[ _ dlsym ] any? ; [ library>> load-library ] bi 2dup check-dlsym ; -: return-size ( ctype -- n ) +: return-size ( c-type -- n ) #! Amount of space we reserve for a return value. { - { [ dup c-struct? not ] [ drop 0 ] } + { [ dup void? ] [ drop 0 ] } + { [ dup base-type struct-c-type? not ] [ drop 0 ] } { [ dup large-struct? not ] [ drop 2 cells ] } [ heap-size ] } cond ; -: ( params -- stack-frame ) - stack-frame new - swap - [ return>> return-size >>return ] - [ alien-parameters [ stack-size ] map-sum >>params ] bi - t >>calls-vm? ; - : alien-node-height ( params -- ) [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; -: emit-alien-node ( node quot -- ) +: emit-alien-block ( node quot: ( params -- ) -- ) '[ make-kill-block params>> - [ ##stack-frame ] - _ - [ alien-node-height ] - tri + _ [ alien-node-height ] bi ] emit-trivial-block ; inline +: ( stack-size return -- stack-frame ) + stack-frame new + swap return-size >>return + swap >>params + t >>calls-vm? ; + +: emit-stack-frame ( stack-size params -- ) + return>> + [ stack-cleanup ##cleanup ] + [ ##stack-frame ] bi ; + M: #alien-invoke emit-node [ { [ objects>registers ] [ alien-invoke-dlsym ##alien-invoke ] - [ stack-cleanup ##cleanup ] + [ emit-stack-frame ] [ box-return* ] } cleave - ] emit-alien-node ; + ] emit-alien-block ; -M: #alien-indirect emit-node - [ - D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr +M:: #alien-indirect emit-node ( node -- ) + node [ + D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src { - [ drop objects>registers ] - [ nip ##alien-indirect ] - [ drop stack-cleanup ##cleanup ] - [ drop box-return* ] - } 2cleave - ] emit-alien-node ; + [ objects>registers ] + [ drop src ##alien-indirect ] + [ emit-stack-frame ] + [ box-return* ] + } cleave + ] emit-alien-block ; M: #alien-assembly emit-node [ - [ objects>registers ] - [ quot>> ##alien-assembly ] - [ box-return* ] - tri - ] emit-alien-node ; + { + [ objects>registers ] + [ quot>> ##alien-assembly ] + [ emit-stack-frame ] + [ box-return* ] + } cleave + ] emit-alien-block ; GENERIC: box-parameter ( n c-type -- dst ) @@ -207,6 +207,10 @@ M: struct-c-type box-parameter : prepare-parameters ( parameters -- offsets types indices ) [ length iota ] [ parameter-offsets ] [ ] tri ; +: alien-parameters ( params -- seq ) + [ parameters>> ] [ return>> large-struct? ] bi + [ struct-return-on-stack? (stack-value) void* ? prefix ] when ; + : box-parameters ( params -- ) alien-parameters [ length ##inc-d ] @@ -276,25 +280,32 @@ M: long-long-type unbox-return M: struct-c-type unbox-return [ ^^unbox-any-c-ptr ] dip ##store-struct-return ; +: emit-callback-stack-frame ( params -- ) + [ alien-parameters [ stack-size ] map-sum ] [ return>> ] bi + ##stack-frame ; + M: #alien-callback emit-node dup params>> xt>> dup [ ##prologue [ - [ registers>objects ] - [ wrap-callback-quot ##alien-callback ] - [ - 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 + { + [ registers>objects ] + [ emit-callback-stack-frame ] + [ wrap-callback-quot ##alien-callback ] + [ + return>> { + { [ dup void? ] [ drop ##end-callback ] } + { [ dup large-struct? ] [ drop ##end-callback ] } + [ + [ D 0 ^^peek ] dip + ##end-callback + base-type unbox-return + ] + } cond + ] + } cleave + ] emit-alien-block ##epilogue ##return ] with-cfg-builder ; diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 059a7f2215..c6d541460a 100644 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -19,8 +19,7 @@ compiler.cfg.instructions compiler.cfg.predecessors compiler.cfg.builder.blocks compiler.cfg.stacks -compiler.cfg.stacks.local -compiler.alien ; +compiler.cfg.stacks.local ; IN: compiler.cfg.builder ! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is From c2558e6a66a9dfc2fd0bcbba7c4a8e54adfb7c7e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 May 2010 23:24:25 -0400 Subject: [PATCH 15/21] vm: fix longlong accessors --- vm/alien.cpp | 4 ++-- vm/primitives.hpp | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/vm/alien.cpp b/vm/alien.cpp index 6d6199b6bc..3d9289a28c 100755 --- a/vm/alien.cpp +++ b/vm/alien.cpp @@ -104,12 +104,12 @@ void *factor_vm::alien_pointer() #define DEFINE_ALIEN_ACCESSOR(name,type,from,to) \ VM_C_API void primitive_alien_##name(factor_vm *parent) \ { \ - parent->ctx->push(from(*(type*)(parent->alien_pointer()),parent)); \ + parent->ctx->push(parent->from(*(type*)(parent->alien_pointer()))); \ } \ VM_C_API void primitive_set_alien_##name(factor_vm *parent) \ { \ type *ptr = (type *)parent->alien_pointer(); \ - type value = (type)to(parent->ctx->pop(),parent); \ + type value = (type)parent->to(parent->ctx->pop()); \ *ptr = value; \ } diff --git a/vm/primitives.hpp b/vm/primitives.hpp index cf52168231..9cda1db9a8 100644 --- a/vm/primitives.hpp +++ b/vm/primitives.hpp @@ -145,8 +145,8 @@ namespace factor _(unsigned_2,u16,from_unsigned_2,to_cell) \ _(signed_1,s8,from_signed_1,to_fixnum) \ _(unsigned_1,u8,from_unsigned_1,to_cell) \ - _(float,float,from_float,to_float) \ - _(double,double,from_double,to_double) \ + _(float,float,allot_float,to_float) \ + _(double,double,allot_float,to_double) \ _(cell,void *,allot_alien,pinned_alien_offset) #define DECLARE_PRIMITIVE(name) VM_C_API void primitive_##name(factor_vm *parent); From f89b85db7b81d67cc22df6fdea6ca9b9cc19a60d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 12 May 2010 01:40:41 -0400 Subject: [PATCH 16/21] Temporary fixes for x86-32 until FFI boxing is rewritten --- basis/compiler/cfg/builder/alien/alien.factor | 19 +++++-- basis/cpu/architecture/architecture.factor | 3 ++ basis/cpu/x86/32/32.factor | 51 +++++++++++++++---- basis/cpu/x86/64/64.factor | 5 ++ basis/cpu/x86/x86.factor | 3 -- 5 files changed, 65 insertions(+), 16 deletions(-) diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index 7f42bdf322..d3bcbd3517 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -64,8 +64,7 @@ M:: struct-c-type unbox-parameter ( src c-type -- ) ] when ; : (objects>registers) ( vregs -- ) - ! Place instructions in reverse order, so that the - ! ##store-stack-param instructions come first. This ensures + ! Place ##store-stack-param instructions first. This ensures ! that no registers are used after the ##store-reg-param ! instructions. [ @@ -73,7 +72,7 @@ M:: struct-c-type unbox-parameter ( src c-type -- ) [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ] [ [ next-reg-param ] keep \ ##store-reg-param new-insn ] if - ] map reverse % ; + ] map [ ##store-stack-param? ] partition [ % ] bi@ ; : objects>registers ( params -- stack-size ) [ abi>> ] [ parameters>> ] [ return>> ] tri @@ -230,8 +229,20 @@ GENERIC: flatten-c-type ( type -- reps ) M: struct-c-type flatten-c-type flatten-struct-type [ first2 [ drop stack-params ] when ] map ; + M: long-long-type flatten-c-type drop { int-rep int-rep } ; -M: c-type flatten-c-type rep>> 1array ; + +M: c-type flatten-c-type + rep>> { + { int-rep [ { int-rep } ] } + { float-rep [ float-on-stack? { stack-params } { float-rep } ? ] } + { double-rep [ + float-on-stack? + cell 4 = { stack-params stack-params } { stack-params } ? + { double-rep } ? + ] } + } case ; + M: object flatten-c-type base-type flatten-c-type ; : flatten-c-types ( types -- reps ) diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 2d9f845c57..3aa1f67356 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -552,6 +552,9 @@ HOOK: dummy-fp-params? cpu ( -- ? ) ! If t, long longs are never passed in param regs HOOK: long-long-on-stack? cpu ( -- ? ) +! If t, floats are never passed in param regs +HOOK: float-on-stack? cpu ( -- ? ) + ! If t, the struct return pointer is never passed in a param reg HOOK: struct-return-on-stack? cpu ( -- ? ) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 68957e0f5f..bbd304ee47 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -7,6 +7,7 @@ command-line make words compiler compiler.units compiler.constants compiler.alien compiler.codegen compiler.codegen.fixup compiler.cfg.instructions compiler.cfg.builder compiler.cfg.builder.alien +compiler.cfg.builder.alien.params compiler.cfg.intrinsics compiler.cfg.stack-frame cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 cpu.architecture vm ; @@ -116,11 +117,37 @@ M: stack-params store-return-reg drop EAX MOV ; M: int-rep load-return-reg drop EAX swap MOV ; M: int-rep store-return-reg drop EAX MOV ; -M: float-rep load-return-reg drop FLDS ; -M: float-rep store-return-reg drop FSTPS ; +:: load-float-return ( src x87-insn sse-insn -- ) + src register? [ + ESP 4 SUB + ESP [] src sse-insn execute + ESP [] x87-insn execute + ESP 4 ADD + ] [ + src x87-insn execute + ] if ; inline -M: double-rep load-return-reg drop FLDL ; -M: double-rep store-return-reg drop FSTPL ; +:: store-float-return ( dst x87-insn sse-insn -- ) + dst register? [ + ESP 4 SUB + ESP [] x87-insn execute + dst ESP [] sse-insn execute + ESP 4 ADD + ] [ + dst x87-insn execute + ] if ; inline + +M: float-rep load-return-reg + drop \ FLDS \ MOVSS load-float-return ; + +M: float-rep store-return-reg + drop \ FSTPS \ MOVSS store-float-return ; + +M: double-rep load-return-reg + drop \ FLDL \ MOVSD load-float-return ; + +M: double-rep store-return-reg + drop \ FSTPL \ MOVSD store-float-return ; M: x86.32 %prologue ( n -- ) dup PUSH @@ -138,9 +165,12 @@ M: x86.32 %prepare-jump M:: x86.32 %unbox ( dst src func rep -- ) src func call-unbox-func - dst rep reg-class-of return-reg rep %copy ; + dst ?spill-slot rep store-return-reg ; -M:: x86.32 %store-long-long-return ( src1 src2 n func -- ) +M:: x86.32 %store-return ( src rep -- ) + src ?spill-slot rep load-return-reg ; + +M:: x86.32 %store-long-long-return ( src1 src2 -- ) src2 EAX = [ src1 src2 XCHG src2 src1 ] [ src1 src2 ] if :> ( src1 src2 ) EAX src1 int-rep %copy EDX src2 int-rep %copy ; @@ -256,9 +286,9 @@ M:: x86.32 %binary-float-function ( dst src1 src2 func -- ) bi and ; : stack-arg-size ( params -- n ) - dup abi>> '[ + dup abi>> [ alien-parameters flatten-c-types - [ _ alloc-parameter 2drop ] each + [ alloc-parameter 2drop ] each stack-params get ] with-param-regs ; @@ -289,7 +319,10 @@ M: x86.32 dummy-fp-params? f ; M: x86.32 long-long-on-stack? t ; -M: x86.32 structs-on-stack? t ; +M: x86.32 float-on-stack? t ; + +M: x86.32 flatten-struct-type + stack-size cell /i { int-rep t } ; M: x86.32 struct-return-on-stack? os linux? not ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 3721c17cf4..0a43961888 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -124,6 +124,9 @@ M:: x86.64 %unbox ( dst src func rep -- ) { float-regs [ float-regs get pop swap MOVSD ] } } case ; +M:: x86.64 %store-return ( src rep -- ) + rep reg-class-of return-reg src rep %copy ; + M:: x86.64 %store-struct-return ( src c-type -- ) ! Move src to R11 so that we don't clobber it. R11 src int-rep %copy @@ -220,6 +223,8 @@ M:: x86.64 %call-gc ( gc-roots -- ) M: x86.64 long-long-on-stack? f ; +M: x86.64 float-on-stack? f ; + M: x86.64 struct-return-on-stack? f ; ! The result of reading 4 bytes from memory is a fixnum on diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index bdf325a826..78e6131795 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -1458,9 +1458,6 @@ M:: x86 %store-reg-param ( src reg rep -- ) M:: x86 %store-stack-param ( src n rep -- ) n param@ src rep %copy ; -M:: x86 %store-return ( src rep -- ) - rep reg-class-of return-reg src rep %copy ; - HOOK: struct-return@ cpu ( n -- operand ) M: x86 %prepare-struct-area ( dst -- ) From 42b0d456cda88dcce42819fba79b5a482d654494 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 12 May 2010 02:09:11 -0400 Subject: [PATCH 17/21] Refactor x86-32 stack cleanup logic --- basis/compiler/cfg/builder/alien/alien.factor | 18 ++++++++-- basis/cpu/architecture/architecture.factor | 4 +-- basis/cpu/x86/32/32.factor | 33 ++++++------------- basis/stack-checker/alien/alien.factor | 8 ++--- 4 files changed, 31 insertions(+), 32 deletions(-) diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index d3bcbd3517..be01a2886e 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -3,7 +3,7 @@ USING: accessors arrays layouts math math.order math.parser combinators combinators.short-circuit fry make sequences locals alien alien.private alien.strings alien.c-types alien.libraries -classes.struct namespaces kernel strings libc quotations +classes.struct namespaces kernel strings libc quotations words cpu.architecture compiler.utilities compiler.tree compiler.cfg compiler.cfg.builder compiler.cfg.builder.alien.params compiler.cfg.builder.blocks compiler.cfg.instructions @@ -151,9 +151,9 @@ M: array dlsym-valid? '[ _ dlsym ] any? ; t >>calls-vm? ; : emit-stack-frame ( stack-size params -- ) - return>> + [ return>> ] [ abi>> ] bi [ stack-cleanup ##cleanup ] - [ ##stack-frame ] bi ; + [ drop ##stack-frame ] 3bi ; M: #alien-invoke emit-node [ @@ -295,6 +295,17 @@ M: struct-c-type unbox-return [ alien-parameters [ stack-size ] map-sum ] [ return>> ] bi ##stack-frame ; +: stack-args-size ( params -- n ) + dup abi>> [ + alien-parameters flatten-c-types + [ alloc-parameter 2drop ] each + stack-params get + ] with-param-regs ; + +: callback-stack-cleanup ( params -- ) + [ xt>> ] [ [ stack-args-size ] [ return>> ] [ abi>> ] tri stack-cleanup ] bi + "stack-cleanup" set-word-prop ; + M: #alien-callback emit-node dup params>> xt>> dup [ @@ -303,6 +314,7 @@ M: #alien-callback emit-node { [ registers>objects ] [ emit-callback-stack-frame ] + [ callback-stack-cleanup ] [ wrap-callback-quot ##alien-callback ] [ return>> { diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 3aa1f67356..b97c45253b 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -605,6 +605,6 @@ HOOK: %alien-callback cpu ( quot -- ) HOOK: %end-callback cpu ( -- ) -HOOK: stack-cleanup cpu ( params -- n ) +HOOK: stack-cleanup cpu ( stack-size return abi -- n ) -M: object stack-cleanup drop 0 ; +M: object stack-cleanup 3drop 0 ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index bbd304ee47..f663523999 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -3,14 +3,10 @@ USING: locals alien alien.c-types alien.libraries alien.syntax arrays kernel fry math namespaces sequences system layouts io vocabs.loader accessors init classes.struct combinators -command-line make words compiler compiler.units -compiler.constants compiler.alien compiler.codegen -compiler.codegen.fixup compiler.cfg.instructions -compiler.cfg.builder compiler.cfg.builder.alien -compiler.cfg.builder.alien.params -compiler.cfg.intrinsics compiler.cfg.stack-frame -cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 -cpu.architecture vm ; +make words compiler.constants compiler.codegen.fixup +compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics +compiler.cfg.stack-frame cpu.x86.assembler cpu.x86.assembler.operands +cpu.x86 cpu.architecture vm ; FROM: layouts => cell ; IN: cpu.x86.32 @@ -279,28 +275,19 @@ M:: x86.32 %binary-float-function ( dst src1 src2 func -- ) func "libm" load-library %alien-invoke dst float-function-return ; -: funny-large-struct-return? ( params -- ? ) +: funny-large-struct-return? ( return abi -- ? ) #! MINGW ABI incompatibility disaster - [ return>> large-struct? ] - [ abi>> mingw eq? os windows? not or ] - bi and ; + [ large-struct? ] [ mingw eq? os windows? not or ] bi* and ; -: stack-arg-size ( params -- n ) - dup abi>> [ - alien-parameters flatten-c-types - [ alloc-parameter 2drop ] each - stack-params get - ] with-param-regs ; - -M: x86.32 stack-cleanup ( params -- n ) +M:: x86.32 stack-cleanup ( stack-size return abi -- n ) #! a) Functions which are stdcall/fastcall/thiscall have to #! clean up the caller's stack frame. #! b) Functions returning large structs on MINGW have to #! fix ESP. { - { [ dup abi>> callee-cleanup? ] [ stack-arg-size ] } - { [ dup funny-large-struct-return? ] [ drop 4 ] } - [ drop 0 ] + { [ abi callee-cleanup? ] [ stack-size ] } + { [ return abi funny-large-struct-return? ] [ 4 ] } + [ 0 ] } cond ; M: x86.32 %cleanup ( n -- ) diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index 1a14ea4297..62dd65c5e0 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors combinators math namespaces init sets words assocs alien.libraries alien alien.private -alien.c-types cpu.architecture fry stack-checker.backend +alien.c-types fry stack-checker.backend stack-checker.errors stack-checker.visitor stack-checker.dependencies ; IN: stack-checker.alien @@ -98,11 +98,11 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; ! Quotation which coerces return value to required type infer-return ; -: callback-xt ( word return-rewind -- alien ) - [ callbacks get ] dip '[ _ ] cache ; +: callback-xt ( word -- alien ) + callbacks get [ dup "stack-cleanup" word-prop ] cache ; : callback-bottom ( params -- ) - [ xt>> ] [ stack-cleanup ] bi '[ _ _ callback-xt ] infer-quot-here ; + xt>> '[ _ callback-xt ] infer-quot-here ; : infer-alien-callback ( -- ) alien-callback-params new From 860e871fe603e314a3be67b3c2627d8be45adf9d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 12 May 2010 13:48:44 -0700 Subject: [PATCH 18/21] new cuda.types vocab containing CUDA vector types (int2, float4, etc.) with CUDA alignment --- extra/cuda/types/types.factor | 292 ++++++++++++++++++++++++++++++++++ 1 file changed, 292 insertions(+) create mode 100644 extra/cuda/types/types.factor diff --git a/extra/cuda/types/types.factor b/extra/cuda/types/types.factor new file mode 100644 index 0000000000..7d16685d8e --- /dev/null +++ b/extra/cuda/types/types.factor @@ -0,0 +1,292 @@ +! (c)2010 Joe Groff bsd license +USING: accessors alien.c-types classes.struct kernel math ; +FROM: alien.c-types => float ; +IN: cuda.types + +STRUCT: char1 + { x char } ; +STRUCT: char2 + { x char } + { y char } ; +STRUCT: char3 + { x char } + { y char } + { z char } ; +STRUCT: char4 + { x char } + { y char } + { z char } + { w char } ; + +STRUCT: uchar1 + { x uchar } ; +STRUCT: uchar2 + { x uchar } + { y uchar } ; +STRUCT: uchar3 + { x uchar } + { y uchar } + { z uchar } ; +STRUCT: uchar4 + { x uchar } + { y uchar } + { z uchar } + { w uchar } ; + +STRUCT: short1 + { x short } ; +STRUCT: short2 + { x short } + { y short } ; +STRUCT: short3 + { x short } + { y short } + { z short } ; +STRUCT: short4 + { x short } + { y short } + { z short } + { w short } ; + +STRUCT: ushort1 + { x ushort } ; +STRUCT: ushort2 + { x ushort } + { y ushort } ; +STRUCT: ushort3 + { x ushort } + { y ushort } + { z ushort } ; +STRUCT: ushort4 + { x ushort } + { y ushort } + { z ushort } + { w ushort } ; + +STRUCT: int1 + { x int } ; +STRUCT: int2 + { x int } + { y int } ; +STRUCT: int3 + { x int } + { y int } + { z int } ; +STRUCT: int4 + { x int } + { y int } + { z int } + { w int } ; + +STRUCT: uint1 + { x uint } ; +STRUCT: uint2 + { x uint } + { y uint } ; +STRUCT: uint3 + { x uint } + { y uint } + { z uint } ; +STRUCT: uint4 + { x uint } + { y uint } + { z uint } + { w uint } ; + +STRUCT: long1 + { x long } ; +STRUCT: long2 + { x long } + { y long } ; +STRUCT: long3 + { x long } + { y long } + { z long } ; +STRUCT: long4 + { x long } + { y long } + { z long } + { w long } ; + +STRUCT: ulong1 + { x ulong } ; +STRUCT: ulong2 + { x ulong } + { y ulong } ; +STRUCT: ulong3 + { x ulong } + { y ulong } + { z ulong } ; +STRUCT: ulong4 + { x ulong } + { y ulong } + { z ulong } + { w ulong } ; + +STRUCT: longlong1 + { x longlong } ; +STRUCT: longlong2 + { x longlong } + { y longlong } ; +STRUCT: longlong3 + { x longlong } + { y longlong } + { z longlong } ; +STRUCT: longlong4 + { x longlong } + { y longlong } + { z longlong } + { w longlong } ; + +STRUCT: ulonglong1 + { x ulonglong } ; +STRUCT: ulonglong2 + { x ulonglong } + { y ulonglong } ; +STRUCT: ulonglong3 + { x ulonglong } + { y ulonglong } + { z ulonglong } ; +STRUCT: ulonglong4 + { x ulonglong } + { y ulonglong } + { z ulonglong } + { w ulonglong } ; + +STRUCT: float1 + { x float } ; +STRUCT: float2 + { x float } + { y float } ; +STRUCT: float3 + { x float } + { y float } + { z float } ; +STRUCT: float4 + { x float } + { y float } + { z float } + { w float } ; + +STRUCT: double1 + { x double } ; +STRUCT: double2 + { x double } + { y double } ; +STRUCT: double3 + { x double } + { y double } + { z double } ; +STRUCT: double4 + { x double } + { y double } + { z double } + { w double } ; + +char2 c-type + 2 >>align + 2 >>align-first + drop +char4 c-type + 4 >>align + 4 >>align-first + drop + +uchar2 c-type + 2 >>align + 2 >>align-first + drop +uchar4 c-type + 4 >>align + 4 >>align-first + drop + +short2 c-type + 4 >>align + 4 >>align-first + drop +short4 c-type + 8 >>align + 8 >>align-first + drop + +ushort2 c-type + 4 >>align + 4 >>align-first + drop +ushort4 c-type + 8 >>align + 8 >>align-first + drop + +int2 c-type + 8 >>align + 8 >>align-first + drop +int4 c-type + 16 >>align + 16 >>align-first + drop + +uint2 c-type + 8 >>align + 8 >>align-first + drop +uint4 c-type + 16 >>align + 16 >>align-first + drop + +long2 c-type + long heap-size 2 * >>align + long heap-size 2 * >>align-first + drop +long4 c-type + 16 >>align + 16 >>align-first + drop + +ulong2 c-type + long heap-size 2 * >>align + long heap-size 2 * >>align-first + drop +ulong4 c-type + 16 >>align + 16 >>align-first + drop + +longlong2 c-type + 16 >>align + 16 >>align-first + drop +longlong4 c-type + 16 >>align + 16 >>align-first + drop + +ulonglong2 c-type + 16 >>align + 16 >>align-first + drop +ulonglong4 c-type + 16 >>align + 16 >>align-first + drop + +float2 c-type + 8 >>align + 8 >>align-first + drop +float4 c-type + 16 >>align + 16 >>align-first + drop + +double2 c-type + 16 >>align + 16 >>align-first + drop +double4 c-type + 16 >>align + 16 >>align-first + drop From db2db6a1a6ddf4846857cfd59c29220be2c61874 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 12 May 2010 18:07:11 -0400 Subject: [PATCH 19/21] compiler.cfg.builder.alien: fix for x86-32 --- basis/compiler/cfg/builder/alien/alien.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/compiler/cfg/builder/alien/alien.factor b/basis/compiler/cfg/builder/alien/alien.factor index be01a2886e..3f529fce9d 100644 --- a/basis/compiler/cfg/builder/alien/alien.factor +++ b/basis/compiler/cfg/builder/alien/alien.factor @@ -241,6 +241,7 @@ M: c-type flatten-c-type cell 4 = { stack-params stack-params } { stack-params } ? { double-rep } ? ] } + { stack-params [ { stack-params } ] } } case ; M: object flatten-c-type base-type flatten-c-type ; From 8b9f33e040b5ddb7ee2fef072410f77afb528ea6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 12 May 2010 18:07:33 -0700 Subject: [PATCH 20/21] x11: convert XSupportsLocale return value to factor bool before testing (bug reported by ceninan) --- basis/x11/x11.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/x11/x11.factor b/basis/x11/x11.factor index 67c94c88ea..d32eaca47e 100644 --- a/basis/x11/x11.factor +++ b/basis/x11/x11.factor @@ -3,6 +3,7 @@ USING: alien.strings continuations io io.encodings.ascii kernel namespaces x11.xlib x11.io vocabs vocabs.loader ; +FROM: alien.c-types => c-bool> ; IN: x11 SYMBOL: dpy @@ -11,7 +12,7 @@ SYMBOL: root : init-locale ( -- ) LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless - XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ; + XSupportsLocale c-bool> [ "XSupportsLocale() failed" print flush ] unless ; : flush-dpy ( -- ) dpy get XFlush drop ; From bb87d124c14076a530052558d58d816e5bde1a49 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 13 May 2010 01:46:58 -0400 Subject: [PATCH 21/21] compiler: small fixes and cleanups --- .../alias-analysis-tests.factor | 21 ++++++++++++++++++- .../cfg/alias-analysis/alias-analysis.factor | 4 ++++ .../cfg/instructions/instructions.factor | 8 +------ basis/compiler/tests/codegen.factor | 7 +++++++ .../known-words/known-words.factor | 5 +++++ .../tree/propagation/propagation-tests.factor | 19 +++++++++++++++++ 6 files changed, 56 insertions(+), 8 deletions(-) diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor index 4a41129ef4..b0085c2032 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor @@ -1,6 +1,6 @@ USING: arrays compiler.cfg.alias-analysis compiler.cfg.instructions compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons -cpu.architecture tools.test ; +cpu.architecture tools.test byte-arrays layouts literals alien ; IN: compiler.cfg.alias-analysis.tests ! Redundant load elimination @@ -242,3 +242,22 @@ IN: compiler.cfg.alias-analysis.tests T{ ##compare f 2 0 1 cc= } } alias-analysis-step ] unit-test + +! Make sure that input to ##box-displaced-alien becomes heap-ac +[ + V{ + T{ ##allot f 1 16 byte-array } + T{ ##load-reference f 2 10 } + T{ ##box-displaced-alien f 3 2 1 4 byte-array } + T{ ##slot-imm f 5 3 1 $[ alien type-number ] } + T{ ##compare f 6 5 1 cc= } + } +] [ + V{ + T{ ##allot f 1 16 byte-array } + T{ ##load-reference f 2 10 } + T{ ##box-displaced-alien f 3 2 1 4 byte-array } + T{ ##slot-imm f 5 3 1 $[ alien type-number ] } + T{ ##compare f 6 5 1 cc= } + } alias-analysis-step +] unit-test diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor index 438395e2a7..e6ecefd665 100644 --- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor +++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor @@ -255,6 +255,10 @@ M: ##allocation analyze-aliases* #! object. dup dst>> set-new-ac ; +M: ##box-displaced-alien analyze-aliases* + [ call-next-method ] + [ base>> heap-ac get merge-acs ] bi ; + M: ##read analyze-aliases* call-next-method dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 28b52e7a4f..4fa8145c4c 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -13,7 +13,7 @@ V{ } clone insn-classes set-global : new-insn ( ... class -- insn ) f swap boa ; inline -! Virtual CPU instructions, used by CFG and machine IRs +! Virtual CPU instructions, used by CFG IR TUPLE: insn ; ! Instructions which are referentially transparent; used for @@ -364,12 +364,6 @@ use: src1 temp: temp/int-rep literal: rep vcc ; -INSN: _test-vector-branch -literal: label -use: src1 -temp: temp/int-rep -literal: rep vcc ; - PURE-INSN: ##add-vector def: dst use: src1 src2 diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 2edb016734..e9127f71e4 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -472,3 +472,10 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read- ] when ; [ ] [ 2000 [ "hello" clone dup gc-root-messup first eq? t assert= ] times ] unit-test + +! Alias analysis bug +[ t ] [ + [ + 10 10 [ underlying>> ] keep eq? + ] compile-call +] unit-test diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 7fb36c96fd..aab40ec77c 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -272,6 +272,11 @@ generic-comparison-ops [ 2drop alien \ f class-or ] "outputs" set-word-prop +\ [ + [ interval>> 0 swap interval-contains? ] dip + class>> alien class-or alien ? +] "outputs" set-word-prop + { } [ [ literal>> dup array? [ first ] [ drop tuple ] if diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 17701e94c1..e738a70fc3 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -976,3 +976,22 @@ M: tuple-with-read-only-slot clone ! Should actually be 0 23 2^ 1 - [a,b] [ string-nth ] final-info first interval>> 0 23 2^ [a,b] = ] unit-test + +! Non-zero displacement for restricts the output type +[ t ] [ + [ { byte-array } declare ] final-classes + first byte-array alien class-or class= +] unit-test + +[ V{ alien } ] [ + [ { alien } declare ] final-classes +] unit-test + +[ t ] [ + [ { POSTPONE: f } declare ] final-classes + first \ f alien class-or class= +] unit-test + +[ V{ alien } ] [ + [ { byte-array } declare [ 10 bitand 2 + ] dip ] final-classes +] unit-test