Adding FFI to new front-end

diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor
index 276dd581c51dcd36de671d65965778fadb2ca6fa..edda9e7fdb4fa13a7a16c1336f6ce9bbf36edd09 100755 (executable)
--- a/basis/alien/c-types/c-types-tests.factor
+++ b/basis/alien/c-types/c-types-tests.factor
@@ -2,6 +2,12 @@ IN: alien.c-types.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
 sequences system libc alien.strings io.encodings.utf8 ;
 
+\ expand-constants must-infer
+
+: xyz 123 ;
+
+[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
+
 : foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
 
 [ 123 ] [ foo ] unit-test

diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index c553ca5cfb178398f1651f61420b703c25c60e8f..a9b39f80abe10c3c81e9b761269d89a83848846e 100755 (executable)
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
 namespaces parser sequences strings words assocs splitting
 math.parser cpu.architecture alien alien.accessors quotations
 layouts system compiler.units io.files io.encodings.binary
-accessors combinators effects ;
+accessors combinators effects continuations ;
 IN: alien.c-types
 
 DEFER: <int>
@@ -239,15 +239,20 @@ M: long-long-type box-return ( type -- )
     } 2cleave ;
 
 : expand-constants ( c-type -- c-type' )
-    #! We use def>> call instead of execute to get around
-    #! staging violations
     dup array? [
-        unclip >r [ dup word? [ def>> call ] when ] map r> prefix
+        unclip >r [
+            dup word? [
+                def>> { } swap with-datastack first
+            ] when
+        ] map r> prefix
     ] when ;
 
 : malloc-file-contents ( path -- alien len )
     binary file-contents dup malloc-byte-array swap length ;
 
+: if-void ( type true false -- )
+    pick "void" = [ drop nip call ] [ nip call ] if ; inline
+
 [
     <c-type>
         [ alien-cell ] >>getter

diff --git a/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor b/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor
index c9caeb864b8ba6208576ebabfc9fbce04f021a4a..d69202c7ad0f7708162da7b4e095e332ca0414da 100644 (file)
--- a/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor
+++ b/unfinished/compiler/tree/dataflow-analysis/backward/backward.factor
@@ -35,6 +35,12 @@ M: #phi backward
     [ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
     2bi ;
 
+M: #alien-invoke backward
+    nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+
+M: #alien-indirect backward
+    nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+
 M: node backward 2drop ;
 
 : backward-dfa ( node quot -- assoc ) [ backward ] dfa ; inline

diff --git a/unfinished/compiler/tree/dead-code/dead-code.factor b/unfinished/compiler/tree/dead-code/dead-code.factor
index 6703f924fd511ccdeb607d51823ac5516d679554..652fa19af330cbbb7854ea0345d9bc2688a5f236 100644 (file)
--- a/unfinished/compiler/tree/dead-code/dead-code.factor
+++ b/unfinished/compiler/tree/dead-code/dead-code.factor
@@ -23,6 +23,12 @@ M: #call mark-live-values
     dup word>> "flushable" word-prop
     [ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
 
+M: #alien-invoke mark-live-values
+    [ look-at-inputs ] [ look-at-outputs ] bi ;
+
+M: #alien-indirect mark-live-values
+    [ look-at-inputs ] [ look-at-outputs ] bi ;
+
 M: #return mark-live-values
     look-at-inputs ;
 

diff --git a/unfinished/compiler/tree/debugger/debugger-tests.factor b/unfinished/compiler/tree/debugger/debugger-tests.factor
index e6a4385c3eed88bba3368756da8f62c6e4feaa85..eb0bbd5ce638299c5a867d33bf29b659f12a518c 100644 (file)
--- a/unfinished/compiler/tree/debugger/debugger-tests.factor
+++ b/unfinished/compiler/tree/debugger/debugger-tests.factor
@@ -1,6 +1,5 @@
 IN: compiler.tree.debugger.tests
 USING: compiler.tree.debugger tools.test ;
 
-\ optimized-quot. must-infer
-\ optimized-word. must-infer
+\ optimized. must-infer
 \ optimizer-report. must-infer

diff --git a/unfinished/compiler/tree/debugger/debugger.factor b/unfinished/compiler/tree/debugger/debugger.factor
index c5b35438b1ffe4a93a76d5b9ee5fa1a0541f12bf..c541311ef2c738c4a176e8cccac34c890da8c015 100644 (file)
--- a/unfinished/compiler/tree/debugger/debugger.factor
+++ b/unfinished/compiler/tree/debugger/debugger.factor
@@ -22,7 +22,7 @@ MACRO: match-choose ( alist -- )
 MATCH-VARS: ?a ?b ?c ;
 
 : pretty-shuffle ( effect -- word/f )
-    [ in>> ] [ out>> ] bi {
+    [ in>> ] [ out>> ] bi 2array {
         { { { } { } } [ ] }
         { { { ?a } { ?a } } [ ] }
         { { { ?a ?b } { ?a ?b } } [ ] }

diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
index c6c407b048d663fe7b1c46541cc2ca05a83bb0e1..af42dc5145433e84f86af8e796483ca2d70fcb68 100644 (file)
--- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor
+++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
@@ -80,3 +80,13 @@ M: #call escape-analysis*
 
 M: #return escape-analysis*
     in-d>> add-escaping-values ;
+
+M: #alien-invoke escape-analysis*
+    [ in-d>> add-escaping-values ]
+    [ out-d>> unknown-allocation ]
+    bi ;
+
+M: #alien-indirect escape-analysis*
+    [ in-d>> add-escaping-values ]
+    [ out-d>> unknown-allocation ]
+    bi ;

diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor
index 42377386256f1a06496fbea37cb6ea293c1b116b..45bbbf19db3df7b48112443346d4ccd0821d579f 100644 (file)
--- a/unfinished/compiler/tree/propagation/simple/simple.factor
+++ b/unfinished/compiler/tree/propagation/simple/simple.factor
@@ -115,3 +115,9 @@ M: #call propagate-before
 M: #call propagate-after
     dup word>> "input-classes" word-prop dup
     [ propagate-input-classes ] [ 2drop ] if ;
+
+M: #alien-invoke propagate-before
+    out-d>> [ object-info swap set-value-info ] each ;
+
+M: #alien-indirect propagate-before
+    out-d>> [ object-info swap set-value-info ] each ;

diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor
index 3db97fdfe0888e3da46876a4a88e54a6a2a34672..175c1ddfdda29bea03d5f2eb3d4a338131784baf 100755 (executable)
--- a/unfinished/compiler/tree/tree.factor
+++ b/unfinished/compiler/tree/tree.factor
@@ -143,6 +143,30 @@ TUPLE: #copy < #renaming in-d out-d ;
         swap >>out-d
         swap >>in-d ;
 
+TUPLE: #alien-node < node params ;
+
+: new-alien-node ( params class -- node )
+    new
+        over in-d>> >>in-d
+        over out-d>> >>out-d
+        swap >>params ; inline
+
+TUPLE: #alien-invoke < #alien-node in-d out-d ;
+
+: #alien-invoke ( params -- node )
+    \ #alien-invoke new-alien-node ;
+
+TUPLE: #alien-indirect < #alien-node in-d out-d ;
+
+: #alien-indirect ( params -- node )
+    \ #alien-indirect new-alien-node ;
+
+TUPLE: #alien-callback < #alien-node ;
+
+: #alien-callback ( params -- node )
+    \ #alien-callback new
+        swap >>params ;
+
 : node, ( node -- ) stack-visitor get push ;
 
 GENERIC: inputs/outputs ( #renaming -- inputs outputs )
@@ -177,3 +201,6 @@ M: vector #phi, #phi node, ;
 M: vector #declare, #declare node, ;
 M: vector #recursive, #recursive node, ;
 M: vector #copy, #copy node, ;
+M: vector #alien-invoke, #alien-invoke node, ;
+M: vector #alien-indirect, #alien-indirect node, ;
+M: vector #alien-callback, #alien-callback node, ;

diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
index 3b832917d8219274ef9eb4941dbfc854a37568b6..1b92d66db4b0bd5414f2b6ff8982b2fb0cbb660e 100644 (file)
--- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
+++ b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor
@@ -128,4 +128,8 @@ M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
 
 M: #introduce unbox-tuples* dup value>> assert-not-unboxed ;
 
+M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ;
+
+M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ;
+
 : unbox-tuples ( nodes -- nodes ) [ unbox-tuples* ] map-nodes ;

diff --git a/unfinished/stack-checker/alien/alien.factor b/unfinished/stack-checker/alien/alien.factor
new file mode 100644 (file)
index 0000000..f81b7fd
--- /dev/null
+++ b/unfinished/stack-checker/alien/alien.factor
@@ -0,0 +1,84 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors combinators math namespaces
+init sets words
+alien alien.c-types
+stack-checker.backend stack-checker.errors stack-checker.visitor ;
+IN: stack-checker.alien
+
+TUPLE: alien-node-params return parameters abi in-d out-d ;
+
+TUPLE: alien-invoke-params < alien-node-params library function ;
+
+TUPLE: alien-indirect-params < alien-node-params ;
+
+TUPLE: alien-callback-params < alien-node-params quot xt ;
+
+: pop-parameters ( -- seq )
+    pop-literal nip [ expand-constants ] map ;
+
+: param-prep-quot ( node -- quot )
+    parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
+
+: 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>> [ [ ] ] [ c-type c-type-boxer-quot ] if-void ;
+
+: infer-alien-invoke ( -- )
+    alien-invoke-params new
+    ! Compile-time parameters
+    pop-parameters >>parameters
+    pop-literal nip >>function
+    pop-literal nip >>library
+    pop-literal nip >>return
+    ! Quotation which coerces parameters to required types
+    dup param-prep-quot recursive-state get infer-quot
+    ! Set ABI
+    dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
+    ! 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 recursive-state get infer-quot ;
+
+: infer-alien-indirect ( -- )
+    alien-indirect-params new
+    ! Compile-time parameters
+    pop-literal nip >>abi
+    pop-parameters >>parameters
+    pop-literal nip >>return
+    ! Quotation which coerces parameters to required types
+    dup param-prep-quot [ dip ] curry recursive-state get infer-quot
+    ! 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 recursive-state get infer-quot ;
+
+! Callbacks are registered in a global hashtable. If you clear
+! this hashtable, they will all be blown away by code GC, beware
+SYMBOL: callbacks
+
+[ H{ } clone callbacks set-global ] "alien.compiler" add-init-hook
+
+: register-callback ( word -- ) callbacks get conjoin ;
+
+: callback-bottom ( params -- )
+    xt>> [ [ register-callback ] [ word-xt drop <alien> ] bi ] curry
+    recursive-state get infer-quot ;
+
+: infer-alien-callback ( -- )
+    alien-callback-params new
+    pop-literal nip >>quot
+    pop-literal nip >>abi
+    pop-parameters >>parameters
+    pop-literal nip >>return
+    gensym >>xt
+    dup callback-bottom
+    #alien-callback, ;

diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor
index fcbf18f01cda942dd54a274b4fd522efd147b0f5..3be2e21b7ecbc023da52297d484b1d3ef26c2488 100644 (file)
--- a/unfinished/stack-checker/inlining/inlining.factor
+++ b/unfinished/stack-checker/inlining/inlining.factor
@@ -32,7 +32,7 @@ M: inline-recursive hashcode* id>> hashcode* ;
 
 : <inline-recursive> ( word -- label )
     inline-recursive new
-        gensym t "inlined-block" set-word-prop >>id
+        gensym dup t "inlined-block" set-word-prop >>id
         swap >>word ;
 
 : quotation-param? ( obj -- ? )

diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor
index 2e0c979f98c596717eddb6e44b9159d85d528529..eb9a9dbdf79cc3f8b1d58482bcf08085b2caef7f 100755 (executable)
--- a/unfinished/stack-checker/known-words/known-words.factor
+++ b/unfinished/stack-checker/known-words/known-words.factor
@@ -10,10 +10,14 @@ sequences sequences.private slots.private strings
 strings.private system threads.private classes.tuple
 classes.tuple.private vectors vectors.private words definitions
 words.private assocs summary compiler.units system.private
-combinators locals.backend stack-checker.state
-stack-checker.backend stack-checker.branches
-stack-checker.errors stack-checker.transforms
-stack-checker.visitor ;
+combinators locals.backend
+stack-checker.state
+stack-checker.backend
+stack-checker.branches
+stack-checker.errors
+stack-checker.transforms
+stack-checker.visitor
+stack-checker.alien ;
 IN: stack-checker.known-words
 
 : infer-primitive ( word -- )
@@ -153,13 +157,15 @@ M: object infer-call*
         { \ get-local [ infer-get-local ] }
         { \ drop-locals [ infer-drop-locals ] }
         { \ do-primitive [ \ do-primitive cannot-infer-effect ] }
+        { \ alien-invoke [ infer-alien-invoke ] }
+        { \ alien-indirect [ infer-alien-indirect ] }
+        { \ alien-callback [ infer-alien-callback ] }
     } case ;
 
 {
-    >r r> declare call curry compose
-    execute if dispatch <tuple-boa>
-    (throw) load-locals get-local drop-locals
-    do-primitive
+    >r r> declare call curry compose execute if dispatch
+    <tuple-boa> (throw) load-locals get-local drop-locals
+    do-primitive alien-invoke alien-indirect alien-callback
 } [ t +special+ set-word-prop ] each
 
 { call execute dispatch load-locals get-local drop-locals }

diff --git a/unfinished/stack-checker/visitor/dummy/dummy.factor b/unfinished/stack-checker/visitor/dummy/dummy.factor
index a1ed5c83a1a9b2cb9efe7a94f4d91d2ac0b2594d..381405bd3174ac181d80efd0bb20bffa8d8dc13e 100644 (file)
--- a/unfinished/stack-checker/visitor/dummy/dummy.factor
+++ b/unfinished/stack-checker/visitor/dummy/dummy.factor
@@ -22,3 +22,6 @@ M: f #declare, drop ;
 M: f #recursive, 2drop 2drop ;
 M: f #copy, 2drop ;
 M: f #drop, drop ;
+M: f #alien-invoke, drop ;
+M: f #alien-indirect, drop ;
+M: f #alien-callback, drop ;

diff --git a/unfinished/stack-checker/visitor/visitor.factor b/unfinished/stack-checker/visitor/visitor.factor
index 3afc8f752d766722b1bfa54532467f4806201bf0..25775ca3f09802cd590fe1b39d970ec8ed69e6db 100644 (file)
--- a/unfinished/stack-checker/visitor/visitor.factor
+++ b/unfinished/stack-checker/visitor/visitor.factor
@@ -27,3 +27,6 @@ HOOK: #enter-recursive, stack-visitor ( label inputs outputs -- )
 HOOK: #return-recursive, stack-visitor ( label inputs outputs -- )
 HOOK: #recursive, stack-visitor ( word label inputs visitor -- )
 HOOK: #copy, stack-visitor ( inputs outputs -- )
+HOOK: #alien-invoke, stack-visitor ( params -- )
+HOOK: #alien-indirect, stack-visitor ( params -- )
+HOOK: #alien-callback, stack-visitor ( params -- )