alien-invoke compiles with VOPs

library/alien/c-types.factor

@@ -1,17 +1,17 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: alien
-USING: assembler errors generic hashtables kernel lists math
+USING: assembler compiler errors generic hashtables kernel lists
-namespaces parser sequences strings words ;
+math namespaces parser sequences strings words ;
 
 : <c-type> ( -- type )
     <namespace> [
         [ "No setter" throw ] "setter" set
         [ "No getter" throw ] "getter" set
         "no boxer" "boxer" set
-        #box "box-op" set
+        \ %box "box-op" set
         "no unboxer" "unboxer" set
-        #unbox "unbox-op" set
+        \ %unbox "unbox-op" set
         0 "width" set
     ] extend ;
 
@@ -170,9 +170,9 @@ global [ c-types nest drop ] bind
     cell "width" set
     cell "align" set
     "box_float" "boxer" set
-    #box-float "box-op" set
+    \ %box-float "box-op" set
     "unbox_float" "unboxer" set
-    #unbox-float "unbox-op" set
+    \ %unbox-float "unbox-op" set
 ] "float" define-primitive-type
 
 [
@@ -181,9 +181,9 @@ global [ c-types nest drop ] bind
     cell 2 * "width" set
     cell 2 * "align" set
     "box_double" "boxer" set
-    #box-double "box-op" set
+    \ %box-double "box-op" set
     "unbox_double" "unboxer" set
-    #unbox-double "unbox-op" set
+    \ %unbox-double "unbox-op" set
 ] "double" define-primitive-type
 
 : alias-c-type ( old new -- )

library/alien/compiler.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: alien
-USING: assembler errors generic inference kernel lists math
+USING: assembler compiler errors generic inference kernel lists
-namespaces sequences stdio strings unparser words ;
+math namespaces sequences stdio strings unparser words ;
 
 ! ! ! WARNING ! ! !
 ! Reloading this file into a running Factor instance on Win32
@@ -48,11 +48,9 @@ M: alien-error error. ( error -- )
     #! namespace.
     drop <alien-error> throw ;
 
-: alien-global ( type library name -- value )
+! These are set in the alien-invoke dataflow IR node.
-    #! Fetch the value of C global variable.
+SYMBOL: alien-returns
-    #! 'type' is a type spec. 'library' is an entry in the
+SYMBOL: alien-parameters
-    #! "libraries" namespace.
-    <alien-error> throw ;
 
 : set-alien-returns ( returns node -- )
     [ dup alien-returns set ] bind
@@ -76,8 +74,6 @@ M: alien-error error. ( error -- )
     [ set-alien-parameters ] keep
     set-alien-returns ;
 
-DEFER: alien-invoke
-
 : infer-alien-invoke ( -- )
     \ alien-invoke "infer-effect" word-prop car ensure-d
     pop-literal
@@ -86,27 +82,13 @@ DEFER: alien-invoke
     pop-literal -rot
     r> swap alien-invoke-node ;
 
-: alien-global-node ( type name library -- )
-    2dup ensure-dlsym
-    cons \ alien-global dataflow,
-    set-alien-returns ;
-
-DEFER: alien-global
-
-: infer-alien-global ( -- )
-    \ alien-global "infer-effect" word-prop car ensure-d
-    pop-literal
-    pop-literal
-    pop-literal -rot
-    alien-global-node ;
-
 : parameters [ alien-parameters get reverse ] bind ;
 
 : stack-space ( parameters -- n )
     0 swap [ c-size cell align + ] each ;
 
 : unbox-parameter ( n parameter -- )
-    c-type [ "unboxer" get cons "unbox-op" get ] bind swons , ;
+    c-type [ "unboxer" get cons "unbox-op" get ] bind execute , ;
 
 : linearize-parameters ( node -- count )
     #! Generate code for boxing a list of C types, then generate
@@ -117,42 +99,31 @@ DEFER: alien-global
     #! Return amount stack must be unwound by.
     parameters
     dup stack-space
-    dup #parameters swons , >r
+    dup %parameters , >r
     dup dup length swap [ >r 1 - dup r> unbox-parameter ] each drop
-    length [ #parameter swons ] project % r> ;
+    length [ %parameter ] project % r> ;
 
 : linearize-returns ( returns -- )
     [ alien-returns get ] bind dup "void" = [
         drop
     ] [
-        c-type [ "boxer" get "box-op" get ] bind swons ,
+        c-type [ "boxer" get "box-op" get ] bind execute ,
     ] ifte ;
 
 : linearize-alien-invoke ( node -- )
     dup linearize-parameters >r
-    dup [ node-param get ] bind \ alien-invoke swons ,
+    dup [ node-param get ] bind %alien-invoke ,
     dup [ node-param get cdr library-abi "stdcall" = ] bind
-    r> swap [ drop ] [ #cleanup swons , ] ifte
+    r> swap [ drop ] [ %cleanup , ] ifte
     linearize-returns ;
 
 \ alien-invoke [ linearize-alien-invoke ] "linearizer" set-word-prop
 
-: linearize-alien-global ( node -- )
-    dup [ node-param get ] bind \ alien-global swons ,
-    linearize-returns ;
-
-\ alien-global [ linearize-alien-global ] "linearizer" set-word-prop
-
 \ alien-invoke [ [ string string string general-list ] [ ] ]
 "infer-effect" set-word-prop
 
 \ alien-invoke [ infer-alien-invoke ] "infer" set-word-prop
 
-\ alien-global [ [ string string string ] [ object ] ]
-"infer-effect" set-word-prop
-
-\ alien-global [ infer-alien-global ] "infer" set-word-prop
-
 global [
     "libraries" get [ <namespace> "libraries" set ] unless
 ] bind

library/alien/dataflow.factor

@@ -1,24 +0,0 @@
-IN: alien
-
-! Linear IR nodes
-
-SYMBOL: #cleanup ( unwind stack by parameter )
-
-SYMBOL: #unbox ( move top of datastack to C stack )
-SYMBOL: #unbox-float
-SYMBOL: #unbox-double
-
-! for register parameter passing; move top of C stack to a
-! register. no-op on x86, generates code on PowerPC.
-SYMBOL: #parameter
-
-! for increasing stack space on PowerPC; unused on x86.
-SYMBOL: #parameters
-
-SYMBOL: #box ( move EAX to datastack )
-SYMBOL: #box-float
-SYMBOL: #box-double
-
-! These are set in the alien-invoke dataflow IR node.
-SYMBOL: alien-returns
-SYMBOL: alien-parameters

library/bootstrap/boot-stage2.factor

@@ -46,7 +46,6 @@ t [
     "/library/compiler/generator.factor"
     "/library/compiler/compiler.factor"
         
-    "/library/alien/dataflow.factor"
     "/library/alien/c-types.factor"
     "/library/alien/enums.factor"
     "/library/alien/structs.factor"

library/compiler/intrinsics.factor

@@ -143,8 +143,8 @@ words ;
 
 : binary-op-reg ( op out -- )
     >r in-2
-    1 <vreg> 0 <vreg> rot execute ,
     1 %dec-d ,
+    1 <vreg> 0 <vreg> rot execute ,
     r> 0 %replace-d , ;
 
 : binary-op ( node op out -- )

library/compiler/vops.factor

@@ -7,6 +7,9 @@ USING: errors generic kernel namespaces parser ;
 ! representations used by Factor. It is basically a high-level
 ! assembly language. Linear IR operations are called VOPs.
 
+! This file defines all the types of VOPs. A linear IR program
+! is then just a list of VOPs.
+
 ! A virtual register
 TUPLE: vreg n ;
 
@@ -30,6 +33,7 @@ GENERIC: generate-node ( vop -- )
 : src-vop ( src) f f f ;
 : dest-vop ( dest) f swap f f ;
 : src/dest-vop ( src dest) f f ;
+: literal-vop ( literal) >r f f r> f ;
 
 ! miscellanea
 VOP: %prologue
@@ -67,22 +71,22 @@ VOP: %end-dispatch
 VOP: %peek-d
 : %peek-d ( vreg n -- ) >r >r f r> <vreg> r> f <%peek-d> ;
 VOP: %dec-d
-: %dec-d ( n -- ) >r f f r> f <%dec-d> ;
+: %dec-d ( n -- ) literal-vop <%dec-d> ;
 VOP: %replace-d
 : %replace-d ( vreg n -- ) >r <vreg> f r> f <%replace-d> ;
 VOP: %inc-d
-: %inc-d ( n -- ) >r f f r> f <%inc-d> ;
+: %inc-d ( n -- ) literal-vop <%inc-d> ;
 VOP: %immediate
 VOP: %immediate-d
-: %immediate-d ( obj -- ) >r f f r> f <%immediate-d> ;
+: %immediate-d ( obj -- ) literal-vop <%immediate-d> ;
 VOP: %peek-r
 : %peek-r ( vreg n -- ) >r >r f r> <vreg> r> f <%peek-r> ;
 VOP: %dec-r
-: %dec-r ( n -- ) >r f f r> f <%dec-r> ;
+: %dec-r ( n -- ) literal-vop <%dec-r> ;
 VOP: %replace-r
 : %replace-r ( vreg n -- ) >r <vreg> f r> f <%replace-r> ;
 VOP: %inc-r
-: %inc-r ( n -- ) >r f f r> f <%inc-r> ;
+: %inc-r ( n -- ) literal-vop <%inc-r> ;
 
 : in-1 0 0 %peek-d , ;
 : in-2 0 1 %peek-d ,  1 0 %peek-d , ;
@@ -146,3 +150,34 @@ VOP: %untag-fixnum
 
 : check-dest ( vop reg -- )
     swap vop-dest = [ "invalid VOP destination" throw ] unless ;
+
+! alien operations
+VOP: %parameters
+: %parameters ( n -- vop ) literal-vop <%parameters> ;
+
+VOP: %parameter
+: %parameter ( n -- vop ) literal-vop <%parameter> ;
+
+VOP: %cleanup
+: %cleanup ( n -- vop ) literal-vop <%cleanup> ;
+
+VOP: %unbox
+: %unbox ( [[ n func ]] -- vop ) literal-vop <%unbox> ;
+
+VOP: %unbox-float
+: %unbox-float ( [[ n func ]] -- vop ) literal-vop <%unbox-float> ;
+
+VOP: %unbox-double
+: %unbox-double ( [[ n func ]] -- vop ) literal-vop <%unbox-double> ;
+
+VOP: %box
+: %box ( func -- vop ) literal-vop <%box> ;
+
+VOP: %box-float
+: %box-float ( func -- vop ) literal-vop <%box-float> ;
+
+VOP: %box-double
+: %box-double ( [[ n func ]] -- vop ) literal-vop <%box-double> ;
+
+VOP: %alien-invoke
+: %alien-invoke ( func -- vop ) literal-vop <%alien-invoke> ;

library/compiler/x86/alien.factor

@@ -4,51 +4,74 @@ IN: compiler
 USING: alien assembler inference kernel kernel-internals lists
 math memory namespaces words ;
 
-\ alien-invoke [
+M: %alien-invoke generate-node
-    uncons load-library compile-c-call
+    #! call a C function.
-] "generator" set-word-prop
+    vop-literal uncons load-library compile-c-call ;
 
-\ alien-global [
+M: %parameters generate-node
-    uncons load-library 2dup dlsym EAX swap unit MOV f rel-dlsym
-] "generator" set-word-prop
-
-#parameters [
-    drop
-] "generator" set-word-prop
-
-: UNBOX cdr dup f dlsym CALL f t rel-dlsym ;
-
-#unbox [
-    UNBOX  EAX PUSH
-] "generator" set-word-prop
-
-#unbox-float [
-    UNBOX  ESP 4 SUB  [ ESP ] FSTPS
-] "generator" set-word-prop
-
-#unbox-double [
-    UNBOX  ESP 8 SUB  [ ESP ] FSTPL
-] "generator" set-word-prop
-
-#parameter [
     #! x86 does not pass parameters in registers
-    drop
+    drop ;
-] "generator" set-word-prop
 
-: BOX dup f dlsym CALL f t rel-dlsym  EAX POP ;
+M: %parameter generate-node
+    #! x86 does not pass parameters in registers
+    drop ;
 
-#box [
+: UNBOX ( vop -- )
-    EAX PUSH  BOX
+    #! An unboxer function takes a value from the data stack and
-] "generator" set-word-prop
+    #! converts it into a C value.
+    vop-literal cdr f compile-c-call ;
 
-#box-float [
+M: %unbox generate-node
-    ESP 4 SUB  [ ESP ] FSTPS  BOX
+    #! C functions return integers in EAX.
-] "generator" set-word-prop
+    UNBOX
+    #! Push integer on C stack.
+    EAX PUSH ;
 
-#box-double [
+M: %unbox-float generate-node
-    ESP 8 SUB  [ ESP ] FSTPL  BOX  ECX POP
+    #! C functions return floats on the FP stack.
-] "generator" set-word-prop
+    UNBOX
+    #! Push float on C stack.
+    ESP 4 SUB
+    [ ESP ] FSTPS ;
 
-#cleanup [
+M: %unbox-double generate-node
-    dup 0 = [ drop ] [ ESP swap ADD ] ifte
+    #! C functions return doubles on the FP stack.
-] "generator" set-word-prop
+    UNBOX
+    #! Push double on C stack.
+    ESP 8 SUB
+    [ ESP ] FSTPL ;
+
+: BOX ( vop -- )
+    #! A boxer function takes a C value as a parameter and
+    #! converts into a Factor value, and pushes it on the data
+    #! stack.
+    vop-literal f compile-c-call ;
+
+M: %box generate-node
+    #! C functions return integers in EAX.
+    EAX PUSH
+    #! Push integer on data stack.
+    BOX
+    ESP 4 ADD ;
+
+M: %box-float generate-node
+    #! C functions return floats on the FP stack.
+    ESP 4 SUB
+    [ ESP ] FSTPS
+    #! Push float on data stack.
+    BOX
+    ESP 4 ADD ;
+
+M: %box-double generate-node
+    #! C functions return doubles on the FP stack.
+    ESP 8 SUB
+    [ ESP ] FSTPL
+    #! Push double on data stack.
+    BOX
+    ESP 8 ADD ;
+
+M: %cleanup generate-node
+    #! In the cdecl ABI, the caller must pop input parameters
+    #! off the C stack. In stdcall, the callee does it, so
+    #! this node is not used in that case.
+    vop-literal dup 0 = [ drop ] [ ESP swap ADD ] ifte ;