From 0deedd48f93b314dc09bc29c5af8fcde46a116a7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 25 Dec 2004 20:52:08 +0000 Subject: [PATCH] some FFI cleanups --- library/compiler/alien.factor | 90 ++++++++++++++++----------- library/compiler/compiler.factor | 7 ++- library/compiler/generator-x86.factor | 8 ++- library/compiler/generator.factor | 16 ++++- library/hashtables.factor | 4 +- library/inference/words.factor | 2 +- library/test/alien.factor | 11 ++++ library/test/inference.factor | 2 + 8 files changed, 95 insertions(+), 45 deletions(-) diff --git a/library/compiler/alien.factor b/library/compiler/alien.factor index 87a219d3f0..11d35a7517 100644 --- a/library/compiler/alien.factor +++ b/library/compiler/alien.factor @@ -38,6 +38,17 @@ USE: namespaces USE: parser USE: words USE: hashtables +USE: strings + +! Command line parameters specify libraries to load. +! +! -library::name= -- define a library , to be +! loaded from the DLL. +! +! -library::abi=stdcall -- define a library using the +! stdcall ABI. This ABI is usually used on Win32. Any other abi +! parameter, or a missing abi parameter indicates the cdecl ABI +! should be used, which is common on Unix. BUILTIN: dll 15 BUILTIN: alien 16 @@ -56,8 +67,8 @@ M: alien = ( obj obj -- ? ) 2drop f ] ifte ; -: (library) ( name -- object ) - "libraries" get hash ; +: library ( name -- object ) + dup [ "libraries" get hash ] when ; : load-dll ( library -- dll ) "dll" get dup [ @@ -72,7 +83,6 @@ M: alien = ( obj obj -- ? ) ] extend put ] bind ; -SYMBOL: #c-invoke ( C ABI -- Unix and some Windows libs ) SYMBOL: #cleanup ( unwind stack by parameter ) SYMBOL: #c-call ( jump to raw address ) @@ -80,74 +90,81 @@ SYMBOL: #c-call ( jump to raw address ) SYMBOL: #unbox ( move top of datastack to C stack ) SYMBOL: #box ( move EAX to datastack ) -SYMBOL: #std-invoke ( stdcall ABI -- Win32 ) +: library-abi ( library -- abi ) + library [ [ "abi" get ] bind ] [ "cdecl" ] ifte* ; -: abi ( -- abi ) - "abi" get "stdcall" = #std-invoke #c-invoke ? ; +: alien-symbol ( function library -- address ) + library [ [ load-dll ] bind dlsym ] [ dlsym-self ] ifte* ; -: alien-function ( function library -- address abi ) - [ - (library) [ load-dll dlsym abi ] bind - ] [ - dlsym-self #c-invoke - ] ifte* ; +SYMBOL: #alien-invoke -! These are set in the #c-invoke and #std-invoke dataflow IR -! nodes. +! These are set in the #alien-invoke dataflow IR node. SYMBOL: alien-returns SYMBOL: alien-parameters +: set-alien-returns ( returns node -- ) + [ dup alien-returns set ] bind + "void" = [ + [ object ] produce-d 1 0 node-outputs + ] unless ; + +: set-alien-parameters ( parameters node -- ) + [ dup alien-parameters set ] bind + [ drop object ] map dup dup ensure-d + length 0 node-inputs consume-d ; + +: alien-node ( returns params function library -- ) + cons #alien-invoke dataflow, + [ set-alien-parameters ] keep + set-alien-returns ; + : infer-alien ( -- ) [ object object object object ] ensure-d dataflow-drop, pop-d literal-value + dataflow-drop, pop-d literal-value >r dataflow-drop, pop-d literal-value - dataflow-drop, pop-d literal-value alien-function >r - dataflow-drop, pop-d literal-value swap - r> dataflow, [ - alien-returns set - alien-parameters set - ] bind ; + dataflow-drop, pop-d literal-value -rot + r> swap alien-node ; -: unbox-parameter ( function -- ) - dlsym-self #unbox swons , ; +: box-parameter + c-type [ + "width" get cell align + "unboxer" get + ] bind #unbox swons , ; : linearize-parameters ( params -- count ) #! Generate code for boxing a list of C types. #! Return amount stack must be unwound by. [ alien-parameters get reverse ] bind 0 swap [ - c-type [ - "width" get cell align + - "unboxer" get - ] bind unbox-parameter + box-parameter + ] each ; -: box-parameter ( function -- ) - dlsym-self #box swons , ; - : linearize-returns ( returns -- ) [ alien-returns get ] bind dup "void" = [ drop ] [ - c-type [ "boxer" get ] bind box-parameter + c-type [ "boxer" get ] bind #box swons , ] ifte ; : linearize-alien ( node -- ) dup linearize-parameters >r dup [ node-param get ] bind #c-call swons , - dup [ node-op get #c-invoke = ] bind - r> swap [ #cleanup swons , ] [ drop ] ifte + dup [ node-param get car "stdcall" = ] bind + r> swap [ drop ] [ #cleanup swons , ] ifte linearize-returns ; -#c-invoke [ linearize-alien ] "linearizer" set-word-property - -#std-invoke [ linearize-alien ] "linearizer" set-word-property +#alien-invoke [ linearize-alien ] "linearizer" set-word-property : alien-invoke ( ... returns library function parameters -- ... ) #! Call a C library function. #! 'returns' is a type spec, and 'parameters' is a list of #! type specs. 'library' is an entry in the "libraries" #! namespace. - "alien-invoke cannot be interpreted." throw ; + [ + "alien-invoke cannot be interpreted. " , + "Either the compiler is disabled, " , + "or the ``" , rot , "'' library is missing. " , + ] make-string throw ; \ alien-invoke [ [ object object object object ] [ ] ] "infer-effect" set-word-property @@ -157,4 +174,3 @@ SYMBOL: alien-parameters global [ "libraries" get [ "libraries" set ] unless ] bind - diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor index a17d1115d3..0d017aee09 100644 --- a/library/compiler/compiler.factor +++ b/library/compiler/compiler.factor @@ -28,6 +28,7 @@ IN: compiler USE: inference USE: errors +USE: generic USE: hashtables USE: kernel USE: lists @@ -56,7 +57,11 @@ USE: words ] when dup word-parameter ; -: (compile) ( word -- ) +GENERIC: (compile) ( word -- ) + +M: word (compile) drop ; + +M: compound (compile) ( word -- ) #! Should be called inside the with-compiler scope. compiling dataflow optimize linearize simplify generate ; diff --git a/library/compiler/generator-x86.factor b/library/compiler/generator-x86.factor index 65c6aa0b71..8954d22b7b 100644 --- a/library/compiler/generator-x86.factor +++ b/library/compiler/generator-x86.factor @@ -128,16 +128,18 @@ USE: math compiled-offset 0 compile-cell 0 defer-xt rel-address ] "generator" set-word-property -#c-call [ CALL JUMP-FIXUP ] "generator" set-word-property +#c-call [ + uncons alien-symbol CALL JUMP-FIXUP +] "generator" set-word-property #unbox [ - CALL JUMP-FIXUP + dlsym-self CALL JUMP-FIXUP EAX PUSH-R ] "generator" set-word-property #box [ EAX PUSH-R - CALL JUMP-FIXUP + dlsym-self CALL JUMP-FIXUP 4 ESP R+I ] "generator" set-word-property diff --git a/library/compiler/generator.factor b/library/compiler/generator.factor index 809cdd4b53..9c6cb16af5 100644 --- a/library/compiler/generator.factor +++ b/library/compiler/generator.factor @@ -81,7 +81,7 @@ SYMBOL: relocation-table dup [ compile-cell ] vector-each vector-length cell * ; -: generate ( word linear -- ) +: (generate) ( word linear -- ) #! Compile a word definition from linear IR. 100 relocation-table set begin-assembly swap >r >r @@ -90,4 +90,18 @@ SYMBOL: relocation-table r> set-compiled-cell r> set-compiled-cell ; +SYMBOL: previous-offset + +: generate ( word linear -- ) + #! If generation fails, reset compiled offset. + [ + compiled-offset previous-offset set + (generate) + ] [ + [ + previous-offset get set-compiled-offset + rethrow + ] when* + ] catch ; + #label [ save-xt ] "generator" set-word-property diff --git a/library/hashtables.factor b/library/hashtables.factor index e777958c73..c642a0a89c 100644 --- a/library/hashtables.factor +++ b/library/hashtables.factor @@ -83,13 +83,13 @@ PREDICATE: vector hashtable ( obj -- ? ) : hash-each ( hash code -- ) #! Apply the code to each key/value pair of the hashtable. - swap [ swap dup >r each r> ] vector-each drop ; + swap [ swap dup >r each r> ] vector-each drop ; inline : hash-subset ( hash code -- hash ) #! Return a new hashtable containing all key/value pairs #! for which the predicate yielded a true value. The #! predicate must have stack effect ( obj -- ? ). - swap [ swap dup >r subset r> swap ] vector-map nip ; + swap [ swap dup >r subset r> swap ] vector-map nip ; inline : hash-keys ( hash -- list ) #! Push a list of keys in a hashtable. diff --git a/library/inference/words.factor b/library/inference/words.factor index fe6635cf2b..3e5c91b095 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -39,7 +39,7 @@ USE: words USE: hashtables USE: parser -: with-dataflow ( param op [ in | out ] quot -- ) +: with-dataflow ( param op [ intypes outtypes ] quot -- ) #! Take input parameters, execute quotation, take output #! parameters, add node. The quotation is called with the #! stack effect. diff --git a/library/test/alien.factor b/library/test/alien.factor index 65d9a1944f..fec1163c50 100644 --- a/library/test/alien.factor +++ b/library/test/alien.factor @@ -2,6 +2,7 @@ IN: scratchpad USE: alien USE: kernel USE: test +USE: inference [ t ] [ 0 0 = ] unit-test [ f ] [ 0 local-alien? ] unit-test @@ -9,3 +10,13 @@ USE: test [ f ] [ 0 1024 = ] unit-test [ f ] [ "hello" 1024 = ] unit-test [ t ] [ 1024 local-alien? ] unit-test + +: alien-inference-1 + "void" "foobar" "boo" [ "short" "short" ] alien-invoke ; + +[ [ 2 | 0 ] ] [ [ alien-inference-1 ] infer old-effect ] unit-test + +: alien-inference-2 + "int" "foobar" "boo" [ "short" "short" ] alien-invoke ; + +[ [ 2 | 1 ] ] [ [ alien-inference-2 ] infer old-effect ] unit-test diff --git a/library/test/inference.factor b/library/test/inference.factor index c20b85c7e1..7d9bb4f837 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -196,6 +196,8 @@ SYMBOL: sym-test [ [ 1 | 1 ] ] [ [ get ] infer old-effect ] unit-test +[ [ 1 | 1 ] ] [ [ str>number ] infer old-effect ] unit-test + ! Type inference [ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test