Further work on callbacks

TODO.FACTOR.txt

@@ -67,6 +67,8 @@
 - [ [ dup call ] dup call ] infer hangs
 - the invalid recursion form case needs to be fixed, for inlines too
 - code gc
+- clean up C stack frame assembly code to avoid moving spilled arguments
+  twice
 
 + misc:
 
@@ -77,3 +79,4 @@
 - delegating generic words with a non-standard picker
   - pass an integer stack pos instead of a quotation
 - make 3.4 bits>double an error
+- colorcoded prettyprinting for vocabularies

library/alien/alien-callback.factor

@@ -32,9 +32,21 @@ M: alien-callback-error summary ( error -- )
     callback-bottom
 ] "infer" set-word-prop
 
+: box-parameters ( parameters -- )
+    [ box-parameter , ] reverse-each-parameter ;
+
+: registers>objects ( parameters -- )
+    #! The corresponding unnest_stacks() call is made by the
+    #! run_nullary_callback() and run_unary_callback() runtime
+    #! functions.
+    dup stack-space %parameters ,
+    dup \ %freg>stack move-parameters
+    "nest_stacks" f %alien-invoke ,
+    box-parameters ;
+
 : linearize-callback ( node -- )
     dup alien-callback-xt [
-        "nest_stacks" f %alien-invoke ,
+        dup alien-callback-parameters registers>objects
         alien-callback-quot %nullary-callback ,
         %return ,
     ] make-linear ;

library/alien/alien-invoke.factor

@@ -43,65 +43,25 @@ M: alien-invoke-error summary ( error -- )
     node,
 ] "infer" set-word-prop
 
-: parameter-size c-size cell align ;
-
-: stack-space ( parameters -- n )
-    0 [ parameter-size + ] reduce ;
-
 : unbox-parameter ( stack# type -- node )
     c-type [ "reg-class" get "unboxer" get ] bind call ;
 
-: unbox-parameters ( params -- )
-    reverse
-    [ stack-space ] keep
-    [ [ parameter-size - dup ] keep unbox-parameter , ] each
-    drop ;
+: unbox-parameters ( parameters -- )
+    [ unbox-parameter , ] reverse-each-parameter ;
 
-: reg-class-full? ( class -- ? )
-    dup class get swap fastcall-regs length >= ;
-
-: spill-param ( reg-class -- n reg-class )
-    reg-size stack-params dup get -rot +@ T{ stack-params } ;
-
-: fastcall-param ( reg-class -- n reg-class )
-    [ dup class get swap inc-reg-class ] keep ;
-
-: load-parameter ( n parameter -- node )
-    #! n is a stack location, and the value of the class
-    #! variable is a register number.
-    c-type "reg-class" swap hash dup reg-class-full?
-    [ spill-param ] [ fastcall-param ] if %parameter ;
-
-: flatten-value-types ( params -- params )
-    #! Convert value type structs to consecutive void*s.
-    [
-        dup c-struct?
-        [ c-size cell / "void*" <array> ] [ 1array ] if
-    ] map concat ;
-
-: load-parameters ( params -- )
-    [
-        flatten-value-types
-        0 { int-regs float-regs stack-params } [ set ] each-with
-        0 [ 2dup load-parameter , parameter-size + ] reduce drop
-    ] with-scope ;
-
-: linearize-parameters ( parameters -- )
+: objects>registers ( parameters -- )
     #! Generate code for boxing a list of C types, then generate
     #! code for moving these parameters to register on
     #! architectures where parameters are passed in registers
-    #! (PowerPC).
+    #! (PowerPC, AMD64).
     dup stack-space %parameters ,
     dup unbox-parameters
     "save_stacks" f %alien-invoke ,
-    load-parameters ;
+    \ %stack>freg move-parameters ;
 
-: linearize-return ( node -- )
-    alien-invoke-return dup "void" = [
-        drop
-    ] [
-        c-type [ "reg-class" get "boxer" get ] bind call ,
-    ] if ;
+: box-return ( node -- )
+    alien-invoke-return dup "void" =
+    [ drop ] [ f swap box-parameter , ] if ;
 
 : linearize-cleanup ( node -- )
     dup alien-invoke-library library-abi "stdcall" = [
@@ -111,10 +71,10 @@ M: alien-invoke-error summary ( error -- )
     ] if ;
 
 M: alien-invoke linearize* ( node -- )
-    dup alien-invoke-parameters linearize-parameters
+    dup alien-invoke-parameters objects>registers
     dup alien-invoke-dlsym %alien-invoke ,
     dup linearize-cleanup
-    dup linearize-return
+    dup box-return
     linearize-next ;
 
 : parse-arglist ( lst -- types stack effect )

library/alien/compiler.factor

@@ -0,0 +1,58 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: alien
+USING: arrays compiler-backend generic hashtables kernel
+kernel-internals math namespaces sequences words ;
+
+: parameter-size c-size cell align ;
+
+: parameter-sizes ( types -- offsets )
+    #! Compute stack frame locations.
+    0 [ parameter-size + ] accumulate ;
+
+: stack-space ( parameters -- n )
+    0 [ parameter-size + ] reduce ;
+
+: reg-class-full? ( class -- ? )
+    dup class get swap fastcall-regs length >= ;
+
+: spill-param ( reg-class -- n reg-class )
+    reg-size stack-params dup get -rot +@ T{ stack-params } ;
+
+: fastcall-param ( reg-class -- n reg-class )
+    [ dup class get swap inc-reg-class ] keep ;
+
+: alloc-parameter ( parameter -- n reg reg-class )
+    #! Allocate a register and stack frame location.
+    #! n is a stack location, and the value of the class
+    #! variable is a register number.
+    c-type "reg-class" swap hash dup reg-class-full?
+    [ spill-param ] [ fastcall-param ] if ;
+
+: flatten-value-types ( params -- params )
+    #! Convert value type structs to consecutive void*s.
+    [
+        dup c-struct?
+        [ c-size cell / "void*" <array> ] [ 1array ] if
+    ] map concat ;
+
+: reverse-each-parameter ( parameters quot -- )
+    >r [ parameter-sizes ] keep
+    [ reverse-slice ] 2apply r> 2each ; inline
+
+: each-parameter ( parameters quot -- )
+    >r [ parameter-sizes ] keep r> 2each ; inline
+
+: move-parameters ( params vop -- )
+    #! Moves values from C stack to registers (if vop is
+    #! %stack>freg) and registers to C stack (if vop is
+    #! %freg>stack).
+    swap [
+        flatten-value-types
+        0 { int-regs float-regs stack-params } [ set ] each-with
+        [ pick >r alloc-parameter r> execute , ] each-parameter
+        drop
+    ] with-scope ; inline
+
+: box-parameter ( stack# type -- node )
+    c-type [ "reg-class" get "boxer" get ] bind call ;

library/bootstrap/boot-stage1.factor

@@ -140,6 +140,7 @@ 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/compiler/ppc/alien.factor

@@ -1,25 +1,25 @@
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 IN: compiler-backend
-USING: alien assembler kernel math ;
+USING: alien assembler kernel math sequences ;
 
-GENERIC: store-insn ( offset reg-class -- )
+GENERIC: freg>stack ( stack reg reg-class -- )
 
-GENERIC: load-insn ( elt parameter reg-class -- )
+GENERIC: stack>freg ( stack reg reg-class -- )
 
-M: int-regs store-insn drop >r 3 1 r> stack@ STW ;
+M: int-regs freg>stack drop 1 rot stack@ STW ;
 
-M: int-regs load-insn drop 3 + 1 rot stack@ LWZ ;
+M: int-regs stack>freg drop 1 rot stack@ LWZ ;
 
-M: float-regs store-insn
-    >r >r 1 1 r> stack@ r>
-    float-regs-size 4 = [ STFS ] [ STFD ] if ;
+: STF float-regs-size 4 = [ STFS ] [ STFD ] if ;
 
-M: float-regs load-insn
-    >r 1+ 1 rot stack@ r> 
-    float-regs-size 4 = [ LFS ] [ LFD ] if ;
+M: float-regs freg>stack >r 1 rot stack@ r> STF ;
 
-M: stack-params load-insn
+: LF float-regs-size 4 = [ LFS ] [ LFD ] if ;
+
+M: float-regs stack>freg >r 1 rot stack@ r> LF ;
+
+M: stack-params stack>freg
     drop >r 0 1 rot stack@ LWZ 0 1 r> stack@ STW ;
 
 M: %unbox generate-node ( vop -- )
@@ -27,7 +27,7 @@ M: %unbox generate-node ( vop -- )
     ! Call the unboxer
     2 input f compile-c-call
     ! Store the return value on the C stack
-    0 input 1 input store-insn ;
+    0 input 1 input [ return-reg ] keep freg>stack ;
 
 M: %unbox-struct generate-node ( vop -- )
     drop
@@ -38,11 +38,23 @@ M: %unbox-struct generate-node ( vop -- )
     ! Copy the struct to the stack
     "unbox_value_struct" f compile-c-call ;
 
-M: %parameter generate-node ( vop -- )
-    ! Move a value from the C stack into the fastcall register
-    drop 0 input 1 input 2 input load-insn ;
+: (%move) 0 input 1 input 2 input [ fastcall-regs nth ] keep ;
 
-M: %box generate-node ( vop -- ) drop 1 input f compile-c-call ;
+M: %stack>freg generate-node ( vop -- )
+    ! Move a value from the C stack into the fastcall register
+    drop (%move) stack>freg ;
+
+M: %freg>stack generate-node ( vop -- )
+    ! Move a value from a fastcall register to the C stack
+    drop (%move) freg>stack ;
+
+M: %box generate-node ( vop -- )
+    drop
+    ! If the source is a stack location, load it into freg #0.
+    ! If the source is f, then we assume the value is already in
+    ! freg #0.
+    0 input [ 0 1 input stack>freg ] when*
+    2 input f compile-c-call ;
 
 M: %cleanup generate-node ( vop -- ) drop ;
 

library/compiler/ppc/architecture.factor

@@ -13,10 +13,10 @@ USING: assembler compiler-backend kernel kernel-internals math ;
 : vregs { 3 4 5 6 7 8 9 10 } ; inline
 
 M: int-regs return-reg drop 3 ;
-M: int-regs fastcall-regs drop 8 ;
+M: int-regs fastcall-regs drop { 3 4 5 6 7 8 9 10 } ;
 
 M: float-regs return-reg drop 1 ;
-M: float-regs fastcall-regs drop 8 ;
+M: float-regs fastcall-regs drop { 1 2 3 4 5 6 7 8 } ;
 
 ! Mach-O -vs- Linux/PPC
 : stack@ os "macosx" = 24 8 ? + ;

library/compiler/vops.factor

@@ -43,15 +43,17 @@ M: float-regs inc-reg-class
     dup class inc
     os "macosx" = [ reg-size 4 / int-regs +@ ] [ drop ] if ;
 
+! A pseudo-register class for parameters spilled on the stack
+TUPLE: stack-params ;
+
+M: stack-params fastcall-regs drop 0 ;
+
 ! A data stack location.
 TUPLE: ds-loc n ;
 
 ! A call stack location.
 TUPLE: cs-loc n ;
 
-! A pseudo-register class for parameters spilled on the stack
-TUPLE: stack-params ;
-
 GENERIC: v>operand
 
 M: integer v>operand tag-bits shift ;
@@ -353,9 +355,13 @@ C: %parameters make-vop ;
 M: %parameters stack-reserve vop-inputs first ;
 : %parameters ( n -- vop ) src-vop <%parameters> ;
 
-TUPLE: %parameter ;
-C: %parameter make-vop ;
-: %parameter ( n reg reg-class -- vop ) 3-in-vop <%parameter> ;
+TUPLE: %stack>freg ;
+C: %stack>freg make-vop ;
+: %stack>freg ( n reg reg-class -- vop ) 3-in-vop <%stack>freg> ;
+
+TUPLE: %freg>stack ;
+C: %freg>stack make-vop ;
+: %freg>stack ( n reg reg-class -- vop ) 3-in-vop <%freg>stack> ;
 
 TUPLE: %cleanup ;
 C: %cleanup make-vop ;
@@ -372,7 +378,7 @@ C: %unbox-struct make-vop ;
 
 TUPLE: %box ;
 C: %box make-vop ;
-: %box ( reg-class func -- vop ) 2-in-vop <%box> ;
+: %box ( n reg-class func -- vop ) 3-in-vop <%box> ;
 
 TUPLE: %alien-invoke ;
 C: %alien-invoke make-vop ;

library/test/compiler/callbacks.factor

@@ -1,5 +1,5 @@
 IN: temporary
-USING: alien compiler errors inference io kernel memory
+USING: alien compiler errors inference io kernel math memory
 namespaces test threads ;
 
 : callback-1 "void" { } [ ] alien-callback ; compiled
@@ -52,3 +52,16 @@ FUNCTION: void callback_test_1 void* callback ; compiled
     "void" { } [ yield "hi" print flush yield ] alien-callback ; compiled
 
 [ ] [ callback-7 callback_test_1 ] unit-test
+
+: callback-8
+    "void" { "int" "int" } [ / "x" set ] alien-callback ;
+    compiled
+
+! FUNCTION: void callback_test_2 void* callback int x int y ;
+! compiled
+! 
+! [ 3/4 ] [
+!     [
+!         "x" off callback-8 3 4 callback_test_2 "x" get
+!     ] with-scope
+! ] unit-test

native/alien.c

@@ -44,21 +44,21 @@ void *alien_offset(CELL object)
 	}
 }
 
-/* pop ( alien n ) from datastack, return alien's address plus n */
-INLINE void *alien_pointer(void)
-{
-	F_FIXNUM offset = unbox_signed_cell();
-	return alien_offset(dpop()) + offset;
-}
-
 /* pop an object representing a C pointer */
 void *unbox_alien(void)
 {
 	return alien_offset(dpop());
 }
 
+/* pop ( alien n ) from datastack, return alien's address plus n */
+INLINE void *alien_pointer(void)
+{
+	F_FIXNUM offset = unbox_signed_cell();
+	return unbox_alien() + offset;
+}
+
 /* make an alien */
-ALIEN *alien(void* ptr)
+ALIEN *alien(void *ptr)
 {
 	ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN));
 	alien->ptr = ptr;

native/factor.c

@@ -61,7 +61,7 @@ int main(int argc, char** argv)
 		printf(" +Xn   Code heap size, megabytes\n");
 		printf("Other options are handled by the Factor library.\n");
 		printf("See the documentation for details.\n");
-		printf("Send bug reports to Slava Pestov <slava@jedit.org>.\n");
+		printf("Send bug reports to Slava Pestov <slava@factorcode.org>.\n");
 		return 1;
 	}
 

native/ffi_test.c

@@ -91,3 +91,12 @@ void callback_test_1(void (*callback)())
 	printf("callback_test_1 leaving\n");
 	fflush(stdout);
 }
+
+void callback_test_2(void (*callback)(int x, int y), int x, int y)
+{
+	printf("callback_test_2 entry\n");
+	fflush(stdout);
+	callback(x,y);
+	printf("callback_test_2 leaving\n");
+	fflush(stdout);
+}

native/run.c

@@ -84,7 +84,6 @@ void run_nullary_callback(CELL quot)
 {
 	call(quot);
 	run(false);
-	unnest_stacks();
 }
 
 /* Called by compiled callbacks after nest_stacks() and boxing registers */
@@ -92,7 +91,6 @@ CELL run_unary_callback(CELL quot)
 {
 	CELL retval;
 	
-	nest_stacks();
 	call(quot);
 	run(false);
 	retval = dpeek();