diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 7eef53ceaf..f6d17337c5 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -44,3 +44,9 @@ - document tools - document conventions - new turtle graphics tutorial +- better line spacing in ui +- use vertex arrays and display lists to speed up ui +- tabular formatting +- float intrinsics +- complex float type +- complex float intrinsics diff --git a/library/alien/alien-callback.factor b/library/alien/alien-callback.factor new file mode 100644 index 0000000000..fdcd81486a --- /dev/null +++ b/library/alien/alien-callback.factor @@ -0,0 +1,52 @@ +! Copyright (C) 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: alien +USING: compiler-backend compiler-frontend errors generic +hashtables inference inspector kernel lists namespaces sequences +strings words ; + +TUPLE: alien-callback return parameters word xt ; +C: alien-callback make-node ; + +TUPLE: alien-callback-error ; + +M: alien-callback-error summary ( error -- ) + drop "Words calling ``alien-callback'' cannot run in the interpreter. Compile the caller word and try again." ; + +: alien-callback ( ... return parameters word -- ... ) + #! Call a C library function. + #! 'return' is a type spec, and 'parameters' is a list of + #! type specs. 'library' is an entry in the "libraries" + #! namespace. + throw ; + +: check-callback ( node -- ) + dup alien-callback-word unit infer dup first + pick alien-callback-parameters length = >r + second swap alien-callback-return "void" = 0 1 ? = r> and [ + "Callback word stack effect does not match callback signature" throw + ] unless ; + +: callback-bottom ( node -- ) + alien-callback-xt [ word-xt ] curry infer-quot ; + +\ alien-callback [ [ string object word ] [ alien ] ] +"infer-effect" set-word-prop + +\ alien-callback [ + empty-node + pop-literal nip over set-alien-callback-word + pop-literal nip over set-alien-callback-parameters + pop-literal nip over set-alien-callback-return + gensym over set-alien-callback-xt + dup check-callback + dup node, + callback-bottom +] "infer" set-word-prop + +: linearize-callback ( node -- linear ) + [ %prologue , alien-callback-word %jump , ] { } make ; + +M: alien-callback linearize* ( node -- ) + dup linearize-callback over alien-callback-xt + linearized get set-hash linearize-next ; diff --git a/library/alien/compiler.factor b/library/alien/alien-invoke.factor similarity index 64% rename from library/alien/compiler.factor rename to library/alien/alien-invoke.factor index fb00343a68..cab6f1b08b 100644 --- a/library/alien/compiler.factor +++ b/library/alien/alien-invoke.factor @@ -6,24 +6,20 @@ compiler-frontend errors generic hashtables inference inspector io kernel kernel-internals lists math namespaces parser prettyprint sequences strings words ; -! USAGE: -! -! Command line parameters given to the runtime specify libraries -! to load. -! -! -libraries::name= -- define a library , to be -! loaded from the DLL. -! -! -libraries::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. +TUPLE: alien-invoke library function return parameters ; +C: alien-invoke make-node ; -! FFI code does not run in the interpreter. +: alien-invoke-stack ( node -- ) + dup alien-invoke-parameters length over consume-values + dup alien-invoke-return "void" = 0 1 ? swap produce-values ; -TUPLE: alien-error library symbol ; +: alien-invoke-dlsym ( node -- symbol dll ) + dup alien-invoke-function swap alien-invoke-library + load-library ; -M: alien-error summary ( error -- ) +TUPLE: alien-invoke-error library symbol ; + +M: alien-invoke-error summary ( error -- ) drop "Words calling ``alien-invoke'' cannot run in the interpreter. Compile the caller word and try again." ; : alien-invoke ( ... return library function parameters -- ... ) @@ -31,30 +27,21 @@ M: alien-error summary ( error -- ) #! 'return' is a type spec, and 'parameters' is a list of #! type specs. 'library' is an entry in the "libraries" #! namespace. - drop throw ; + pick pick throw ; -TUPLE: alien-node return parameters ; -C: alien-node make-node ; +\ alien-invoke [ [ string object string object ] [ ] ] +"infer-effect" set-word-prop -: set-alien-return ( return node -- ) - 2dup set-alien-node-return - swap "void" = [ 1 over produce-values ] unless drop ; - -: set-alien-parameters ( parameters node -- ) - 2dup set-alien-node-parameters - >r length r> consume-values ; - -: ensure-dlsym ( symbol library -- ) load-library dlsym drop ; - -: alien-node ( return params function library -- ) - #! We should fail if the library does not exist, so that - #! compilation does not keep trying to compile FFI words - #! over and over again if the library is not loaded. - 2dup ensure-dlsym - cons param-node - [ set-alien-parameters ] keep - [ set-alien-return ] keep - node, ; +\ alien-invoke [ + empty-node + pop-literal nip over set-alien-invoke-parameters + pop-literal nip over set-alien-invoke-function + pop-literal nip over set-alien-invoke-library + pop-literal nip over set-alien-invoke-return + dup alien-invoke-dlsym dlsym drop + dup alien-invoke-stack + node, +] "infer" set-word-prop : parameter-size c-size cell align ; @@ -108,20 +95,22 @@ C: alien-node make-node ; dup unbox-parameters load-parameters ; : linearize-return ( node -- ) - alien-node-return dup "void" = [ + alien-invoke-return dup "void" = [ drop ] [ c-type [ "reg-class" get "boxer" get ] bind call , ] if ; : linearize-cleanup ( node -- ) - node-param cdr library-abi "stdcall" = [ - dup alien-node-parameters stack-space %cleanup , - ] unless ; + dup alien-invoke-library library-abi "stdcall" = [ + drop + ] [ + alien-invoke-parameters stack-space %cleanup , + ] if ; -M: alien-node linearize* ( node -- ) - dup alien-node-parameters linearize-parameters - dup node-param uncons %alien-invoke , +M: alien-invoke linearize* ( node -- ) + dup alien-invoke-parameters linearize-parameters + dup alien-invoke-dlsym %alien-invoke , dup linearize-cleanup dup linearize-return linearize-next ; @@ -139,24 +128,12 @@ M: alien-node linearize* ( node -- ) : define-c-word ( type lib func function-args -- ) [ "()" subseq? not ] subset parse-arglist (define-c-word) ; -\ alien-invoke [ [ string object string object ] [ ] ] -"infer-effect" set-word-prop - -\ alien-invoke [ - pop-literal nip - pop-literal nip >r - pop-literal nip - pop-literal nip -rot - r> swap alien-node -] "infer" set-word-prop - -global [ "libraries" nest drop ] bind - M: compound (uncrossref) dup word-def \ alien-invoke swap member? over "infer" word-prop or [ drop ] [ - dup { "infer-effect" "base-case" "no-effect" "terminates" } + dup + { "infer-effect" "base-case" "no-effect" "terminates" } reset-props update-xt ] if ; diff --git a/library/alien/aliens.factor b/library/alien/aliens.factor index 72de634896..a96b2940fd 100644 --- a/library/alien/aliens.factor +++ b/library/alien/aliens.factor @@ -1,19 +1,30 @@ -! Copyright (C) 2004, 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. +! Copyright (C) 2004, 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. IN: alien -USING: arrays hashtables io kernel lists math namespaces parser sequences ; +USING: arrays hashtables io kernel lists math namespaces parser +sequences ; + +! USAGE: +! +! Command line parameters given to the runtime specify libraries +! to load. +! +! -libraries::name= -- define a library , to be +! loaded from the DLL. +! +! -libraries::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. UNION: c-ptr byte-array alien displaced-alien ; -M: alien hashcode ( obj -- n ) - alien-address >fixnum ; +M: alien hashcode ( obj -- n ) alien-address >fixnum ; M: alien = ( obj obj -- ? ) - over alien? [ - alien-address swap alien-address = - ] [ - 2drop f - ] if ; + over alien? [ [ alien-address ] 2apply = ] [ 2drop f ] if ; + +global [ "libraries" nest drop ] bind : library ( name -- object ) "libraries" get hash ; diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index ec71154fff..ca55c82728 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -140,7 +140,8 @@ vectors words ; "/library/alien/c-types.factor" "/library/alien/structs.factor" - "/library/alien/compiler.factor" + "/library/alien/alien-invoke.factor" + "/library/alien/alien-callback.factor" "/library/alien/syntax.factor" "/library/alien/malloc.factor" diff --git a/library/compiler/generator.factor b/library/compiler/generator.factor index 59261757b8..5f9a468b7c 100644 --- a/library/compiler/generator.factor +++ b/library/compiler/generator.factor @@ -64,7 +64,7 @@ M: %parameter generate-node ( vop -- ) drop ; M: %alien-invoke generate-node #! call a C function. - drop 0 input 1 input load-library compile-c-call ; + drop 0 input 1 input compile-c-call ; : dest/src ( -- dest src ) 0 output-operand 0 input-operand ; diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor index 8d56cba035..86863e0629 100644 --- a/library/compiler/linearizer.factor +++ b/library/compiler/linearizer.factor @@ -25,12 +25,12 @@ SYMBOL: renamed-labels GENERIC: linearize* ( node -- ) +: make-linear ( word quot -- ) + swap >r [ %prologue , call ] { } make r> + linearized get set-hash ; inline + : linearize-1 ( word dataflow -- ) - #! Transform dataflow IR into linear IR. This strips out - #! stack flow information, and flattens conditionals into - #! jumps and labels. - [ %prologue , linearize* ] { } make - swap linearized get set-hash ; + swap [ linearize* ] make-linear ; : init-linearizer ( -- ) H{ } clone linearized set diff --git a/library/test/compiler/alien.factor b/library/test/compiler/alien.factor index a38ec94c82..d83a983dfe 100644 --- a/library/test/compiler/alien.factor +++ b/library/test/compiler/alien.factor @@ -1,4 +1,5 @@ -USING: alien compiler kernel test ; +IN: temporary +USING: alien compiler kernel namespaces namespaces test ; FUNCTION: void ffi_test_0 ; compiled [ ] [ ffi_test_0 ] unit-test diff --git a/library/test/compiler/callbacks.factor b/library/test/compiler/callbacks.factor new file mode 100644 index 0000000000..e8af49db1d --- /dev/null +++ b/library/test/compiler/callbacks.factor @@ -0,0 +1,18 @@ +IN: temporary +USING: alien compiler inference namespaces test ; + +: no-op ; + +: callback-1 "void" { } \ no-op alien-callback ; compiled + +[ { 0 1 } ] [ [ callback-1 ] infer ] unit-test + +: callback-1-bad "int" { } \ no-op alien-callback ; + +[ [ callback-1-bad ] infer ] unit-test-fails + +[ t ] [ callback-1 alien? ] unit-test + +FUNCTION: void callback_test_1 void* callback ; compiled + +[ ] [ callback-1 callback_test_1 ] unit-test diff --git a/library/test/test.factor b/library/test/test.factor index 12f651ed97..934c8aa126 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -109,5 +109,5 @@ SYMBOL: failures "compiler/generic" "compiler/bail-out" "compiler/linearizer" "compiler/intrinsics" "compiler/identities" "compiler/optimizer" - "compiler/alien" + "compiler/alien" "compiler/callbacks" } run-tests ; diff --git a/native/ffi_test.c b/native/ffi_test.c index c8c46ae3ed..213b2b5495 100644 --- a/native/ffi_test.c +++ b/native/ffi_test.c @@ -82,3 +82,10 @@ int ffi_test_12(int a, int b, struct rect c, int d, int e, int f) printf("ffi_test_12(%d,%d,{%f,%f,%f,%f},%d,%d,%d)\n",a,b,c.x,c.y,c.w,c.h,d,e,f); return a + b + c.x + c.y + c.w + c.h + d + e + f; } + +void callback_test_1(void (*callback)()) +{ + printf("callback_test_1 entry"); + callback(); + printf("callback_test_1 leaving"); +}