Adding FFI to new front-end

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

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

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

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 ;
 

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

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 } } [ ] }

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 ;

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 ;

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, ;

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 ;

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, ;

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 -- ? )

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 }

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 ;

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 -- )