From eb3f8632dd347cc1a1364b4a5388257335884c8b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 22 Feb 2010 21:32:41 +1300 Subject: [PATCH] stack-checker.alien: now that C types are words, the compiler can add dependencies on them when compiling alien words. This triggers the necessary recompilation when C types are redefined --- basis/compiler/tests/redefine24.factor | 39 ++++++++++ basis/stack-checker/alien/alien.factor | 76 +++++++++++++------ .../dependencies/dependencies.factor | 2 + 3 files changed, 92 insertions(+), 25 deletions(-) create mode 100644 basis/compiler/tests/redefine24.factor diff --git a/basis/compiler/tests/redefine24.factor b/basis/compiler/tests/redefine24.factor new file mode 100644 index 0000000000..391102102e --- /dev/null +++ b/basis/compiler/tests/redefine24.factor @@ -0,0 +1,39 @@ +USING: alien alien.syntax eval math tools.test ; +QUALIFIED: alien.c-types +IN: compiler.tests.redefine24 + +TYPEDEF: alien.c-types:int type-1 + +TYPEDEF: alien.c-types:int type-3 + +: callback ( -- ptr ) + type-3 { type-1 type-1 } "cdecl" [ + >integer ] alien-callback ; + +TYPEDEF: alien.c-types:float type-2 + +: indirect ( x y ptr -- z ) + type-3 { type-2 type-2 } "cdecl" alien-indirect ; + +[ ] [ + "USING: alien.c-types alien.syntax ; + IN: compiler.tests.redefine24 TYPEDEF: int type-2" eval( -- ) +] unit-test + +[ 3 ] [ 1 2 callback indirect ] unit-test + +[ ] [ + "USING: alien.c-types alien.syntax ; + IN: compiler.tests.redefine24 + TYPEDEF: float type-1 + TYPEDEF: float type-2" eval( -- ) +] unit-test + +[ 3 ] [ 1.0 2.0 callback indirect ] unit-test + +[ ] [ + "USING: alien.c-types alien.syntax ; + IN: compiler.tests.redefine24 + TYPEDEF: float type-3" eval( -- ) +] unit-test + +[ 3.0 ] [ 1.0 2.0 callback indirect ] unit-test diff --git a/basis/stack-checker/alien/alien.factor b/basis/stack-checker/alien/alien.factor index fdfda6dd9e..09121488ef 100644 --- a/basis/stack-checker/alien/alien.factor +++ b/basis/stack-checker/alien/alien.factor @@ -3,7 +3,7 @@ USING: kernel sequences accessors combinators math namespaces init sets words assocs alien.libraries alien alien.c-types cpu.architecture fry stack-checker.backend stack-checker.errors -stack-checker.visitor ; +stack-checker.visitor stack-checker.dependencies ; IN: stack-checker.alien TUPLE: alien-node-params return parameters abi in-d out-d ; @@ -16,65 +16,91 @@ TUPLE: alien-assembly-params < alien-node-params quot ; TUPLE: alien-callback-params < alien-node-params quot xt ; -: param-prep-quot ( node -- quot ) +: param-prep-quot ( params -- quot ) parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ; +: infer-params ( params -- ) + param-prep-quot infer-quot-here ; + : alien-stack ( params extra -- ) over parameters>> length + consume-d >>in-d dup return>> void? 0 1 ? produce-d >>out-d drop ; -: return-prep-quot ( node -- quot ) +: return-prep-quot ( params -- quot ) return>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ; +: infer-return ( params -- ) + return-prep-quot infer-quot-here ; + +: pop-return ( params -- params ) + pop-literal [ depends-on-c-type ] [ nip >>return ] bi ; + +: pop-library ( params -- params ) + pop-literal nip >>library ; + +: pop-function ( params -- params ) + pop-literal nip >>function ; + +: pop-params ( params -- params ) + pop-literal [ [ depends-on-c-type ] each ] [ nip >>parameters ] bi ; + +: pop-abi ( params -- params ) + pop-literal nip >>abi ; + +: pop-quot ( params -- params ) + pop-literal nip >>quot ; + : infer-alien-invoke ( -- ) alien-invoke-params new ! Compile-time parameters - pop-literal nip >>parameters - pop-literal nip >>function - pop-literal nip >>library - pop-literal nip >>return - ! Quotation which coerces parameters to required types - dup param-prep-quot infer-quot-here + pop-params + pop-function + pop-library + pop-return ! Set ABI dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi + ! Quotation which coerces parameters to required types + dup infer-params ! Magic #: consume exactly the number of inputs dup 0 alien-stack ! Add node to IR dup #alien-invoke, ! Quotation which coerces return value to required type - return-prep-quot infer-quot-here ; + infer-return ; : infer-alien-indirect ( -- ) alien-indirect-params new ! Compile-time parameters - pop-literal nip >>abi - pop-literal nip >>parameters - pop-literal nip >>return + pop-abi + pop-params + pop-return ! Quotation which coerces parameters to required types - dup param-prep-quot '[ _ dip ] infer-quot-here + 1 infer->r + dup infer-params + 1 infer-r> ! Magic #: consume the function pointer, too dup 1 alien-stack ! Add node to IR dup #alien-indirect, ! Quotation which coerces return value to required type - return-prep-quot infer-quot-here ; + infer-return ; : infer-alien-assembly ( -- ) alien-assembly-params new ! Compile-time parameters - pop-literal nip >>quot - pop-literal nip >>abi - pop-literal nip >>parameters - pop-literal nip >>return + pop-quot + pop-abi + pop-params + pop-return ! Quotation which coerces parameters to required types - dup param-prep-quot infer-quot-here + dup infer-params ! Magic #: consume exactly the number of inputs dup 0 alien-stack ! Add node to IR dup #alien-assembly, ! Quotation which coerces return value to required type - return-prep-quot infer-quot-here ; + infer-return ; : callback-xt ( word return-rewind -- alien ) [ callbacks get ] dip '[ _ ] cache ; @@ -85,10 +111,10 @@ TUPLE: alien-callback-params < alien-node-params quot xt ; : infer-alien-callback ( -- ) alien-callback-params new - pop-literal nip >>quot - pop-literal nip >>abi - pop-literal nip >>parameters - pop-literal nip >>return + pop-quot + pop-abi + pop-params + pop-return "( callback )" >>xt dup callback-bottom #alien-callback, ; diff --git a/basis/stack-checker/dependencies/dependencies.factor b/basis/stack-checker/dependencies/dependencies.factor index 1bd7cdcd31..25fe12cbc5 100644 --- a/basis/stack-checker/dependencies/dependencies.factor +++ b/basis/stack-checker/dependencies/dependencies.factor @@ -40,6 +40,8 @@ SYMBOLS: effect-dependency conditional-dependency definition-dependency ; GENERIC: depends-on-c-type ( c-type -- ) +M: void depends-on-c-type drop ; + M: c-type-word depends-on-c-type depends-on-definition ; M: array depends-on-c-type -- 2.34.1