Merge branch 'master' of git://factorcode.org/git/factor

basis/alien/arrays/arrays.factor

@@ -26,8 +26,6 @@ M: array base-type drop void* base-type ;
 
 M: array stack-size drop void* stack-size ;
 
-M: array flatten-c-type drop void* flatten-c-type ;
-
 PREDICATE: string-type < pair
     first2 [ c-string = ] [ word? ] bi* and ;
 
@@ -49,8 +47,6 @@ M: string-type stack-size drop void* stack-size ;
 
 M: string-type c-type-rep drop int-rep ;
 
-M: string-type flatten-c-type drop void* flatten-c-type ;
-
 M: string-type c-type-boxer-quot
     second dup binary =
     [ drop void* c-type-boxer-quot ]

basis/alien/c-types/c-types.factor

@@ -66,15 +66,6 @@ M: word c-type
     dup "c-type" word-prop resolve-typedef
     [ ] [ no-c-type ] ?if ;
 
-GENERIC: c-struct? ( c-type -- ? )
-
-M: object c-struct? drop f ;
-
-M: c-type-name c-struct? dup void? [ drop f ] [ c-type c-struct? ] if ;
-
-! These words being foldable means that words need to be
-! recompiled if a C type is redefined. Even so, folding the
-! size facilitates some optimizations.
 GENERIC: c-type-class ( name -- class )
 
 M: abstract-c-type c-type-class class>> ;
@@ -127,17 +118,6 @@ GENERIC: stack-size ( name -- size )
 
 M: c-type stack-size size>> cell align ;
 
-: (flatten-c-type) ( type rep -- seq )
-    [ stack-size cell /i ] dip <repetition> ; inline
-
-GENERIC: flatten-c-type ( type -- reps )
-
-M: c-type flatten-c-type rep>> 1array ;
-M: c-type-name flatten-c-type c-type flatten-c-type ;
-
-: flatten-c-types ( types -- reps )
-    [ flatten-c-type ] map concat ;
-
 MIXIN: value-type
 
 : c-getter ( name -- quot )
@@ -165,8 +145,7 @@ PROTOCOL: c-type-protocol
     c-type-align-first
     base-type
     heap-size
-    stack-size
+    stack-size ;
-    flatten-c-type ;
 
 CONSULT: c-type-protocol c-type-name
     c-type ;
@@ -185,9 +164,6 @@ TUPLE: long-long-type < c-type ;
 : <long-long-type> ( -- c-type )
     long-long-type new ;
 
-M: long-long-type flatten-c-type
-    int-rep (flatten-c-type) ;
-
 : define-deref ( c-type -- )
     [ name>> CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
     (( c-ptr -- value )) define-inline ;

basis/alien/syntax/syntax-docs.factor

@@ -119,10 +119,6 @@ HELP: typedef
 
 { POSTPONE: TYPEDEF: typedef } related-words
 
-HELP: c-struct?
-{ $values { "c-type" "a C type" } { "?" "a boolean" } }
-{ $description "Tests if a C type is a structure defined by " { $link POSTPONE: STRUCT: } "." } ;
-
 HELP: C-GLOBAL:
 { $syntax "C-GLOBAL: type name" }
 { $values { "type" "a C type" } { "name" "a C global variable name" } }

basis/classes/struct/struct.factor

@@ -166,24 +166,22 @@ INSTANCE: struct-c-type value-type
 
 M: struct-c-type c-type ;
 
-: if-value-struct ( ctype true false -- )
-    [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
-
-: if-small-struct ( c-type true false -- ? )
-    [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
-
 M: struct-c-type base-type ;
 
 M: struct-c-type stack-size
-    [ heap-size cell align ] [ stack-size ] if-value-struct ;
+    dup value-struct? [ heap-size cell align ] [ drop cell ] if ;
 
-HOOK: flatten-struct-type cpu ( type -- reps )
+HOOK: flatten-struct-type cpu ( type -- pairs )
 
-M: object flatten-struct-type int-rep (flatten-c-type) ;
+M: object flatten-struct-type
+    stack-size cell /i { int-rep f } <repetition> ;
 
-M: struct-c-type flatten-c-type flatten-struct-type ;
+: large-struct? ( type -- ? )
-
+    {
-M: struct-c-type c-struct? drop t ;
+        { [ dup void? ] [ drop f ] }
+        { [ dup base-type struct-c-type? not ] [ drop f ] }
+        [ return-struct-in-registers? not ]
+    } cond ;
 
 <PRIVATE
 : struct-slot-values-quot ( class -- quot )

basis/cocoa/messages/messages.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.strings arrays assocs
-classes.struct continuations combinators compiler compiler.alien
+classes.struct continuations combinators compiler
 core-graphics.types stack-checker kernel math namespaces make
 quotations sequences strings words cocoa.runtime cocoa.types io
 macros memoize io.encodings.utf8 effects layouts libc

basis/compiler/alien/alien.factor

@@ -1,15 +0,0 @@
-! Copyright (C) 2008, 2010 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces make math sequences layouts
-alien.c-types cpu.architecture ;
-IN: compiler.alien
-
-: large-struct? ( type -- ? )
-    dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ;
-
-: alien-parameters ( params -- seq )
-    dup parameters>>
-    swap return>> large-struct? [ struct-return-pointer-type prefix ] when ;
-
-: alien-return ( params -- type )
-    return>> dup large-struct? [ drop void ] when ;

basis/compiler/alien/summary.txt

@@ -1 +0,0 @@
-Common code used for analysis and code generation of alien bindings

basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor

@@ -1,6 +1,6 @@
 USING: arrays compiler.cfg.alias-analysis compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
-cpu.architecture tools.test ;
+cpu.architecture tools.test byte-arrays layouts literals alien ;
 IN: compiler.cfg.alias-analysis.tests
 
 ! Redundant load elimination
@@ -242,3 +242,22 @@ IN: compiler.cfg.alias-analysis.tests
         T{ ##compare f 2 0 1 cc= }
     } alias-analysis-step
 ] unit-test
+
+! Make sure that input to ##box-displaced-alien becomes heap-ac
+[
+    V{
+        T{ ##allot f 1 16 byte-array }
+        T{ ##load-reference f 2 10 }
+        T{ ##box-displaced-alien f 3 2 1 4 byte-array }
+        T{ ##slot-imm f 5 3 1 $[ alien type-number ] }
+        T{ ##compare f 6 5 1 cc= }
+    }
+] [
+    V{
+        T{ ##allot f 1 16 byte-array }
+        T{ ##load-reference f 2 10 }
+        T{ ##box-displaced-alien f 3 2 1 4 byte-array }
+        T{ ##slot-imm f 5 3 1 $[ alien type-number ] }
+        T{ ##compare f 6 5 1 cc= }
+    } alias-analysis-step
+] unit-test

basis/compiler/cfg/alias-analysis/alias-analysis.factor

@@ -255,6 +255,10 @@ M: ##allocation analyze-aliases*
     #! object.
     dup dst>> set-new-ac ;
 
+M: ##box-displaced-alien analyze-aliases*
+    [ call-next-method ]
+    [ base>> heap-ac get merge-acs ] bi ;
+
 M: ##read analyze-aliases*
     call-next-method
     dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri

basis/compiler/cfg/builder/alien/alien.factor

@@ -1,121 +1,86 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays layouts math math.order math.parser
-combinators fry sequences locals alien alien.private
+combinators combinators.short-circuit fry make sequences locals
-alien.strings alien.c-types alien.libraries classes.struct
+alien alien.private alien.strings alien.c-types alien.libraries
-namespaces kernel strings libc quotations cpu.architecture
+classes.struct namespaces kernel strings libc quotations words
-compiler.alien compiler.utilities compiler.tree compiler.cfg
+cpu.architecture compiler.utilities compiler.tree compiler.cfg
-compiler.cfg.builder compiler.cfg.builder.blocks
+compiler.cfg.builder compiler.cfg.builder.alien.params
-compiler.cfg.instructions compiler.cfg.stack-frame
+compiler.cfg.builder.blocks compiler.cfg.instructions
-compiler.cfg.stacks compiler.cfg.registers
+compiler.cfg.stack-frame compiler.cfg.stacks
-compiler.cfg.hats ;
+compiler.cfg.registers compiler.cfg.hats ;
 FROM: compiler.errors => no-such-symbol no-such-library ;
 IN: compiler.cfg.builder.alien
 
-GENERIC: next-fastcall-param ( rep -- )
+! output is triples with shape { vreg rep on-stack? }
+GENERIC: unbox ( src c-type -- vregs )
 
-: ?dummy-stack-params ( rep -- )
+M: c-type unbox
-    dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
+    [ [ unboxer>> ] [ rep>> ] bi ^^unbox ] [ rep>> ] bi
+    f 3array 1array ;
 
-: ?dummy-int-params ( rep -- )
+M: long-long-type unbox
-    dummy-int-params? [ rep-size cell /i 1 max int-regs +@ ] [ drop ] if ;
+    unboxer>> int-rep ^^unbox
+    0 cell
+    [
+        int-rep f ^^load-memory-imm
+        int-rep long-long-on-stack? 3array
+    ] bi-curry@ bi 2array ;
 
-: ?dummy-fp-params ( rep -- )
+GENERIC: unbox-parameter ( src c-type -- vregs )
-    drop dummy-fp-params? [ float-regs inc ] when ;
 
-M: int-rep next-fastcall-param
+M: c-type unbox-parameter unbox ;
-    int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
 
-M: float-rep next-fastcall-param
+M: long-long-type unbox-parameter unbox ;
-    float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
 
-M: double-rep next-fastcall-param
+M:: struct-c-type unbox-parameter ( src c-type -- )
-    float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
+    src ^^unbox-any-c-ptr :> src
+    c-type value-struct? [
+        c-type flatten-struct-type
+        [| pair i |
+            src i cells pair first f ^^load-memory-imm
+            pair first2 3array
+        ] map-index
+    ] [ { { src int-rep f } } ] if ;
 
-GENERIC# reg-class-full? 1 ( reg-class abi -- ? )
+: unbox-parameters ( parameters -- vregs )
-
+    [
-M: stack-params reg-class-full? 2drop t ;
+        [ length iota <reversed> ] keep
-
-M: reg-class reg-class-full?
-    [ get ] swap '[ _ param-regs length ] bi >= ;
-
-: alloc-stack-param ( rep -- n reg-class rep )
-    stack-params get
-    [ rep-size cell align stack-params +@ ] dip
-    stack-params dup ;
-
-: alloc-fastcall-param ( rep -- n reg-class rep )
-    [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
-
-:: alloc-parameter ( rep abi -- reg rep )
-    rep dup reg-class-of abi reg-class-full?
-    [ alloc-stack-param ] [ alloc-fastcall-param ] if
-    [ abi param-reg ] dip ;
-
-: reset-fastcall-counts ( -- )
-    { int-regs float-regs stack-params } [ 0 swap set ] each ;
-
-: with-param-regs ( quot -- )
-    #! In quot you can call alloc-parameter
-    [ reset-fastcall-counts call ] with-scope ; inline
-
-:: move-parameters ( params word -- )
-    #! Moves values from C stack to registers (if word is
-    #! ##load-param-reg) and registers to C stack (if word is
-    #! ##save-param-reg).
-    0 params alien-parameters flatten-c-types [
-        [ params abi>> alloc-parameter word execute( offset reg rep -- ) ]
-        [ rep-size cell align + ]
-        2bi
-    ] each drop ; inline
-
-: parameter-offsets ( types -- offsets )
-    0 [ stack-size + ] accumulate nip ;
-
-: prepare-parameters ( parameters -- offsets types indices )
-    [ length iota <reversed> ] [ parameter-offsets ] [ ] tri ;
-
-GENERIC: unbox-parameter ( src n c-type -- )
-
-M: c-type unbox-parameter
-    [ rep>> ] [ unboxer>> ] bi ##unbox ;
-
-M: long-long-type unbox-parameter
-    unboxer>> ##unbox-long-long ;
-
-M: struct-c-type unbox-parameter
-    [ [ ^^unbox-any-c-ptr ] 2dip ##unbox-large-struct ]
-    [ base-type unbox-parameter ]
-    if-value-struct ;
-
-: unbox-parameters ( offset node -- )
-    parameters>> swap
-    '[
-        prepare-parameters
         [
-            [ <ds-loc> ^^peek ] [ _ + ] [ base-type ] tri*
+            [ <ds-loc> ^^peek ] [ base-type ] bi*
             unbox-parameter
-        ] 3each
+        ] 2map concat
     ]
-    [ length neg ##inc-d ]
+    [ length neg ##inc-d ] bi ;
-    bi ;
 
-: prepare-box-struct ( node -- offset )
+: prepare-struct-area ( vregs return -- vregs )
     #! Return offset on C stack where to store unboxed
     #! parameters. If the C function is returning a structure,
     #! the first parameter is an implicit target area pointer,
     #! so we need to use a different offset.
-    return>> large-struct?
+    large-struct? [
-    [ ##prepare-box-struct cell ] [ 0 ] if ;
+        ^^prepare-struct-area int-rep struct-return-on-stack?
+        3array prefix
+    ] when ;
 
-: objects>registers ( params -- )
+: (objects>registers) ( vregs -- )
-    #! Generate code for unboxing a list of C types, then
+    ! Place ##store-stack-param instructions first. This ensures
-    #! generate code for moving these parameters to registers on
+    ! that no registers are used after the ##store-reg-param
-    #! architectures where parameters are passed in registers.
+    ! instructions.
     [
-        [ prepare-box-struct ] keep
+        first3 [ dup reg-class-of reg-class-full? ] dip or
-        [ unbox-parameters ] keep
+        [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]
-        \ ##load-param-reg move-parameters
+        [ [ next-reg-param ] keep \ ##store-reg-param new-insn ]
+        if
+    ] map [ ##store-stack-param? ] partition [ % ] bi@ ;
+
+: objects>registers ( params -- stack-size )
+    [ abi>> ] [ parameters>> ] [ return>> ] tri
+    '[ 
+        _ unbox-parameters
+        _ prepare-struct-area
+        (objects>registers)
+        stack-params get
     ] with-param-regs ;
 
 GENERIC: box-return ( c-type -- dst )
@@ -127,7 +92,8 @@ M: long-long-type box-return
     [ f ] dip boxer>> ^^box-long-long ;
 
 M: struct-c-type box-return
-    [ ^^box-small-struct ] [ ^^box-large-struct ] if-small-struct ;
+    dup return-struct-in-registers?
+    [ ^^box-small-struct ] [ [ f ] dip ^^box-large-struct ] if ;
 
 : box-return* ( node -- )
     return>> [ ] [ base-type box-return 1 ##inc-d D 0 ##replace ] if-void ;
@@ -159,63 +125,66 @@ M: array dlsym-valid? '[ _ dlsym ] any? ;
     [ library>> load-library ]
     bi 2dup check-dlsym ;
 
-: return-size ( ctype -- n )
+: return-size ( c-type -- n )
     #! Amount of space we reserve for a return value.
     {
-        { [ dup c-struct? not ] [ drop 0 ] }
+        { [ dup void? ] [ drop 0 ] }
+        { [ dup base-type struct-c-type? not ] [ drop 0 ] }
         { [ dup large-struct? not ] [ drop 2 cells ] }
         [ heap-size ]
     } cond ;
 
-: <alien-stack-frame> ( params -- stack-frame )
-    stack-frame new
-        swap
-        [ return>> return-size >>return ]
-        [ alien-parameters [ stack-size ] map-sum >>params ] bi
-        t >>calls-vm? ;
-
 : alien-node-height ( params -- )
     [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
 
-: emit-alien-node ( node quot -- )
+: emit-alien-block ( node quot: ( params -- ) -- )
     '[
         make-kill-block
         params>>
-        [ <alien-stack-frame> ##stack-frame ]
+        _ [ alien-node-height ] bi
-        _
-        [ alien-node-height ]
-        tri
     ] emit-trivial-block ; inline
 
+: <alien-stack-frame> ( stack-size return -- stack-frame )
+    stack-frame new
+        swap return-size >>return
+        swap >>params
+        t >>calls-vm? ;
+
+: emit-stack-frame ( stack-size params -- )
+    [ return>> ] [ abi>> ] bi
+    [ stack-cleanup ##cleanup ]
+    [ drop <alien-stack-frame> ##stack-frame ] 3bi ;
+
 M: #alien-invoke emit-node
     [
-        ! Unbox parameters
-        dup objects>registers
-        ! Call function
-        dup alien-invoke-dlsym ##alien-invoke
-        ! Box return value
-        dup ##cleanup
-        box-return*
-    ] emit-alien-node ;
-
-M: #alien-indirect emit-node
-    [
-        D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr
         {
-            [ drop objects>registers ]
+            [ objects>registers ]
-            [ nip ##alien-indirect ]
+            [ alien-invoke-dlsym ##alien-invoke ]
-            [ drop ##cleanup ]
+            [ emit-stack-frame ]
-            [ drop box-return* ]
+            [ box-return* ]
-        } 2cleave
+        } cleave
-    ] emit-alien-node ;
+    ] emit-alien-block ;
+
+M:: #alien-indirect emit-node ( node -- )
+    node [
+        D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
+        {
+            [ objects>registers ]
+            [ drop src ##alien-indirect ]
+            [ emit-stack-frame ]
+            [ box-return* ]
+        } cleave
+    ] emit-alien-block ;
 
 M: #alien-assembly emit-node
     [
-        [ objects>registers ]
+        {
-        [ quot>> ##alien-assembly ]
+            [ objects>registers ]
-        [ box-return* ]
+            [ quot>> ##alien-assembly ]
-        tri
+            [ emit-stack-frame ]
-    ] emit-alien-node ;
+            [ box-return* ]
+        } cleave
+    ] emit-alien-block ;
 
 GENERIC: box-parameter ( n c-type -- dst )
 
@@ -225,9 +194,22 @@ M: c-type box-parameter
 M: long-long-type box-parameter
     boxer>> ^^box-long-long ;
 
+: if-value-struct ( ctype true false -- )
+    [ dup value-struct? ] 2dip '[ drop void* @ ] if ; inline
+
 M: struct-c-type box-parameter
     [ ^^box-large-struct ] [ base-type box-parameter ] if-value-struct ;
 
+: parameter-offsets ( types -- offsets )
+    0 [ stack-size + ] accumulate nip ;
+
+: prepare-parameters ( parameters -- offsets types indices )
+    [ length iota <reversed> ] [ parameter-offsets ] [ ] tri ;
+
+: alien-parameters ( params -- seq )
+    [ parameters>> ] [ return>> large-struct? ] bi
+    [ struct-return-on-stack? (stack-value) void* ? prefix ] when ;
+
 : box-parameters ( params -- )
     alien-parameters
     [ length ##inc-d ]
@@ -239,10 +221,45 @@ M: struct-c-type box-parameter
         ] 3each
     ] bi ;
 
-: registers>objects ( node -- )
+:: alloc-parameter ( rep -- reg rep )
+    rep dup reg-class-of reg-class-full?
+    [ alloc-stack-param stack-params ] [ [ next-reg-param ] keep ] if ;
+
+GENERIC: flatten-c-type ( type -- reps )
+
+M: struct-c-type flatten-c-type
+    flatten-struct-type [ first2 [ drop stack-params ] when ] map ;
+    
+M: long-long-type flatten-c-type drop { int-rep int-rep } ;
+
+M: c-type flatten-c-type
+    rep>> {
+        { int-rep [ { int-rep } ] }
+        { float-rep [ float-on-stack? { stack-params } { float-rep } ? ] }
+        { double-rep [
+            float-on-stack?
+            cell 4 = { stack-params stack-params } { stack-params } ?
+            { double-rep } ?
+        ] }
+        { stack-params [ { stack-params } ] }
+    } case ;
+    
+M: object flatten-c-type base-type flatten-c-type ;
+
+: flatten-c-types ( types -- reps )
+    [ flatten-c-type ] map concat ;
+
+: (registers>objects) ( params -- )
+    [ 0 ] dip alien-parameters flatten-c-types [
+        [ alloc-parameter ##save-param-reg ]
+        [ rep-size cell align + ]
+        2bi
+    ] each drop ; inline
+
+: registers>objects ( params -- )
     ! Generate code for boxing input parameters in a callback.
-    [
+    dup abi>> [
-        dup \ ##save-param-reg move-parameters
+        dup (registers>objects)
         ##begin-callback
         next-vreg next-vreg ##restore-context
         box-parameters
@@ -267,30 +284,52 @@ M: struct-c-type box-parameter
 GENERIC: unbox-return ( src c-type -- )
 
 M: c-type unbox-return
-    [ f ] dip [ rep>> ] [ unboxer>> ] bi ##unbox ;
+    unbox first first2 ##store-return ;
 
 M: long-long-type unbox-return
-    [ f ] dip unboxer>> ##unbox-long-long ;
+    unbox first2 [ first ] bi@ ##store-long-long-return ;
 
 M: struct-c-type unbox-return
-    [ ^^unbox-any-c-ptr ] dip
+    [ ^^unbox-any-c-ptr ] dip ##store-struct-return ;
-    [ ##unbox-small-struct ] [ ##unbox-large-struct ] if-small-struct ;
+
+: emit-callback-stack-frame ( params -- )
+    [ alien-parameters [ stack-size ] map-sum ] [ return>> ] bi
+    <alien-stack-frame> ##stack-frame ;
+
+: stack-args-size ( params -- n )
+    dup abi>> [
+        alien-parameters flatten-c-types
+        [ alloc-parameter 2drop ] each
+        stack-params get
+    ] with-param-regs ;
+
+: callback-stack-cleanup ( params -- )
+    [ xt>> ] [ [ stack-args-size ] [ return>> ] [ abi>> ] tri stack-cleanup ] bi
+    "stack-cleanup" set-word-prop ;
 
 M: #alien-callback emit-node
     dup params>> xt>> dup
     [
         ##prologue
         [
-            [ registers>objects ]
+            {
-            [ wrap-callback-quot ##alien-callback ]
+                [ registers>objects ]
-            [
+                [ emit-callback-stack-frame ]
-                alien-return [ ##end-callback ] [
+                [ callback-stack-cleanup ]
-                    [ D 0 ^^peek ] dip
+                [ wrap-callback-quot ##alien-callback ]
-                    ##end-callback
+                [
-                    base-type unbox-return
+                    return>> {
-                ] if-void
+                        { [ dup void? ] [ drop ##end-callback ] }
-            ] tri
+                        { [ dup large-struct? ] [ drop ##end-callback ] }
-        ] emit-alien-node
+                        [
+                            [ D 0 ^^peek ] dip
+                            ##end-callback
+                            base-type unbox-return
+                        ]
+                    } cond
+                ]
+            } cleave
+        ] emit-alien-block
         ##epilogue
         ##return
     ] with-cfg-builder ;

basis/compiler/cfg/builder/alien/params/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/compiler/cfg/builder/alien/params/params.factor

@@ -0,0 +1,49 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cpu.architecture fry kernel layouts math math.order
+namespaces sequences vectors ;
+IN: compiler.cfg.builder.alien.params
+
+: alloc-stack-param ( rep -- n )
+    stack-params get
+    [ rep-size cell align stack-params +@ ] dip ;
+
+: ?dummy-stack-params ( rep -- )
+    dummy-stack-params? [ alloc-stack-param drop ] [ drop ] if ;
+
+: ?dummy-int-params ( rep -- )
+    dummy-int-params? [
+        rep-size cell /i 1 max
+        [ int-regs get [ pop* ] unless-empty ] times
+    ] [ drop ] if ;
+
+: ?dummy-fp-params ( rep -- )
+    drop dummy-fp-params? [ float-regs get [ pop* ] unless-empty ] when ;
+
+GENERIC: next-reg-param ( rep -- reg )
+
+M: int-rep next-reg-param
+    [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi int-regs get pop ;
+
+M: float-rep next-reg-param
+    [ ?dummy-stack-params ] [ ?dummy-int-params ] bi float-regs get pop ;
+
+M: double-rep next-reg-param
+    [ ?dummy-stack-params ] [ ?dummy-int-params ] bi float-regs get pop ;
+
+GENERIC: reg-class-full? ( reg-class -- ? )
+
+M: stack-params reg-class-full? drop t ;
+
+M: reg-class reg-class-full? get empty? ;
+
+: init-reg-class ( abi reg-class -- )
+    [ swap param-regs <reversed> >vector ] keep set ;
+
+: with-param-regs ( abi quot -- )
+    '[
+        [ int-regs init-reg-class ]
+        [ float-regs init-reg-class ] bi
+        0 stack-params set
+        @
+    ] with-scope ; inline

basis/compiler/cfg/builder/builder.factor

@@ -19,8 +19,7 @@ compiler.cfg.instructions
 compiler.cfg.predecessors
 compiler.cfg.builder.blocks
 compiler.cfg.stacks
-compiler.cfg.stacks.local
+compiler.cfg.stacks.local ;
-compiler.alien ;
 IN: compiler.cfg.builder
 
 ! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is

basis/compiler/cfg/instructions/instructions.factor

@@ -13,7 +13,7 @@ V{ } clone insn-classes set-global
 
 : new-insn ( ... class -- insn ) f swap boa ; inline
 
-! Virtual CPU instructions, used by CFG and machine IRs
+! Virtual CPU instructions, used by CFG IR
 TUPLE: insn ;
 
 ! Instructions which are referentially transparent; used for
@@ -364,12 +364,6 @@ use: src1
 temp: temp/int-rep
 literal: rep vcc ;
 
-INSN: _test-vector-branch
-literal: label
-use: src1
-temp: temp/int-rep
-literal: rep vcc ;
-
 PURE-INSN: ##add-vector
 def: dst
 use: src1 src2
@@ -612,6 +606,33 @@ literal: offset ;
 INSN: ##stack-frame
 literal: stack-frame ;
 
+INSN: ##unbox
+def: dst
+use: src/tagged-rep
+literal: unboxer rep ;
+
+INSN: ##store-reg-param
+use: src
+literal: reg rep ;
+
+INSN: ##store-stack-param
+use: src
+literal: n rep ;
+
+INSN: ##store-return
+use: src
+literal: rep ;
+
+INSN: ##store-struct-return
+use: src/int-rep
+literal: c-type ;
+
+INSN: ##store-long-long-return
+use: src1/int-rep src2/int-rep ;
+
+INSN: ##prepare-struct-area
+def: dst/int-rep ;
+
 INSN: ##box
 def: dst/tagged-rep
 literal: n rep boxer ;
@@ -628,32 +649,11 @@ INSN: ##box-large-struct
 def: dst/tagged-rep
 literal: n c-type ;
 
-INSN: ##unbox
-use: src/tagged-rep
-literal: n rep unboxer ;
-
-INSN: ##unbox-long-long
-use: src/tagged-rep
-literal: n unboxer ;
-
-INSN: ##unbox-large-struct
-use: src/int-rep
-literal: n c-type ;
-
-INSN: ##unbox-small-struct
-use: src/int-rep
-literal: c-type ;
-
-INSN: ##prepare-box-struct ;
-
-INSN: ##load-param-reg
-literal: offset reg rep ;
-
 INSN: ##alien-invoke
 literal: symbols dll ;
 
 INSN: ##cleanup
-literal: params ;
+literal: n ;
 
 INSN: ##alien-indirect
 use: src/int-rep ;
@@ -815,11 +815,10 @@ UNION: clobber-insn
 ##box-small-struct
 ##box-large-struct
 ##unbox
-##unbox-long-long
+##store-reg-param
-##unbox-large-struct
+##store-return
-##unbox-small-struct
+##store-struct-return
-##prepare-box-struct
+##store-long-long-return
-##load-param-reg
 ##alien-invoke
 ##alien-indirect
 ##alien-assembly

basis/compiler/cfg/linear-scan/allocation/allocation.factor

@@ -1,7 +1,9 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs heaps kernel namespaces sequences fry math
+USING: accessors assocs binary-search combinators
-math.order combinators arrays sorting compiler.utilities locals
+combinators.short-circuit heaps kernel namespaces
+sequences fry locals math math.order arrays sorting
+compiler.utilities
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.allocation.spilling
 compiler.cfg.linear-scan.allocation.splitting
@@ -34,15 +36,15 @@ IN: compiler.cfg.linear-scan.allocation
         [ drop assign-blocked-register ]
     } cond ;
 
-: spill-at-sync-point ( live-interval n -- ? )
+: spill-at-sync-point ( n live-interval -- ? )
     ! If the live interval has a definition at 'n', don't spill
-    2dup [ uses>> ] dip
+    2dup find-use
-    '[ [ def-rep>> ] [ n>> _ = ] bi and ] any?
+    { [ ] [ def-rep>> ] } 1&&
-    [ 2drop t ] [ spill f ] if ;
+    [ 2drop t ] [ swap spill f ] if ;
 
 : handle-sync-point ( n -- )
-    [ active-intervals get values ] dip
+    active-intervals get values
-    '[ [ _ spill-at-sync-point ] filter! drop ] each ;
+    [ [ spill-at-sync-point ] with filter! drop ] with each ;
 
 :: handle-progress ( n sync? -- )
     n {
@@ -69,11 +71,7 @@ M: sync-point handle ( sync-point -- )
     } cond ;
 
 : (allocate-registers) ( -- )
-    ! If a live interval begins at the same location as a sync point,
+    unhandled-intervals get unhandled-sync-points get smallest-heap
-    ! process the sync point before the live interval. This ensures that the
-    ! return value of C function calls doesn't get spilled and reloaded
-    ! unnecessarily.
-    unhandled-sync-points get unhandled-intervals get smallest-heap
     dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
 
 : finish-allocation ( -- )

basis/compiler/cfg/linear-scan/allocation/splitting/splitting.factor

@@ -39,7 +39,7 @@ ERROR: splitting-atomic-interval ;
 : check-split ( live-interval n -- )
     check-allocation? get [
         [ [ start>> ] dip > [ splitting-too-early ] when ]
-        [ [ end>> ] dip <= [ splitting-too-late ] when ]
+        [ [ end>> ] dip < [ splitting-too-late ] when ]
         [ drop [ end>> ] [ start>> ] bi = [ splitting-atomic-interval ] when ]
         2tri
     ] [ 2drop ] if ; inline

basis/compiler/cfg/linear-scan/linear-scan-tests.factor

@@ -145,34 +145,24 @@ H{
        { vreg 3 }
        { reg-class float-regs }
        { start 0 }
-       { end 1 }
+       { end 2 }
-       { uses V{ T{ vreg-use f 0 float-rep f } } }
+       { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } } }
-       { ranges V{ T{ live-range f 0 1 } } }
+       { ranges V{ T{ live-range f 0 2 } } }
        { spill-to T{ spill-slot f 8 } }
        { spill-rep float-rep }
     }
-    T{ live-interval
+    f
-       { vreg 3 }
-       { reg-class float-regs }
-       { start 20 }
-       { end 30 }
-       { uses V{ T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } }
-       { ranges V{ T{ live-range f 20 30 } } }
-       { reload-from T{ spill-slot f 8 } }
-       { reload-rep float-rep }
-    }
 ] [
     T{ live-interval
        { vreg 3 }
        { reg-class float-regs }
        { start 0 }
-       { end 30 }
+       { end 5 }
-       { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } }
+       { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 1 f float-rep } T{ vreg-use f 5 f float-rep } } }
-       { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
+       { ranges V{ T{ live-range f 0 5 } } }
-    } 10 split-for-spill
+    } 5 split-for-spill
 ] unit-test
 
-! Don't insert reload if first usage is a def
 [
     T{ live-interval
        { vreg 4 }
@@ -189,12 +179,45 @@ H{
        { reg-class float-regs }
        { start 20 }
        { end 30 }
+       { uses V{ T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } }
+       { ranges V{ T{ live-range f 20 30 } } }
+       { reload-from T{ spill-slot f 12 } }
+       { reload-rep float-rep }
+    }
+] [
+    T{ live-interval
+       { vreg 4 }
+       { reg-class float-regs }
+       { start 0 }
+       { end 30 }
+       { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 20 f float-rep } T{ vreg-use f 30 f float-rep } } }
+       { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
+    } 10 split-for-spill
+] unit-test
+
+! Don't insert reload if first usage is a def
+[
+    T{ live-interval
+       { vreg 5 }
+       { reg-class float-regs }
+       { start 0 }
+       { end 1 }
+       { uses V{ T{ vreg-use f 0 float-rep f } } }
+       { ranges V{ T{ live-range f 0 1 } } }
+       { spill-to T{ spill-slot f 16 } }
+       { spill-rep float-rep }
+    }
+    T{ live-interval
+       { vreg 5 }
+       { reg-class float-regs }
+       { start 20 }
+       { end 30 }
        { uses V{ T{ vreg-use f 20 float-rep f } T{ vreg-use f 30 f float-rep } } }
        { ranges V{ T{ live-range f 20 30 } } }
     }
 ] [
     T{ live-interval
-       { vreg 4 }
+       { vreg 5 }
        { reg-class float-regs }
        { start 0 }
        { end 30 }
@@ -206,28 +229,28 @@ H{
 ! Multiple representations
 [
     T{ live-interval
-       { vreg 5 }
+       { vreg 6 }
        { reg-class float-regs }
        { start 0 }
        { end 11 }
        { uses V{ T{ vreg-use f 0 float-rep f } T{ vreg-use f 10 double-rep float-rep } } }
        { ranges V{ T{ live-range f 0 11 } } }
-       { spill-to T{ spill-slot f 16 } }
+       { spill-to T{ spill-slot f 24 } }
        { spill-rep double-rep }
     }
     T{ live-interval
-       { vreg 5 }
+       { vreg 6 }
        { reg-class float-regs }
        { start 20 }
        { end 20 }
        { uses V{ T{ vreg-use f 20 f double-rep } } }
        { ranges V{ T{ live-range f 20 20 } } }
-       { reload-from T{ spill-slot f 16 } }
+       { reload-from T{ spill-slot f 24 } }
        { reload-rep double-rep }
     }
 ] [
     T{ live-interval
-       { vreg 5 }
+       { vreg 6 }
        { reg-class float-regs }
        { start 0 }
        { end 20 }

basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor

@@ -54,6 +54,10 @@ M: live-interval covers? ( insn# live-interval -- ? )
         covers?
     ] if ;
 
+:: find-use ( insn# live-interval -- vreg-use )
+    insn# live-interval uses>> [ n>> <=> ] with search nip
+    dup [ dup n>> insn# = [ drop f ] unless ] when ;
+
 : add-new-range ( from to live-interval -- )
     [ <live-range> ] dip ranges>> push ;
 

basis/compiler/codegen/codegen.factor

@@ -276,20 +276,21 @@ CONDITIONAL: ##fixnum-sub %fixnum-sub
 CONDITIONAL: ##fixnum-mul %fixnum-mul
 
 ! FFI
+CODEGEN: ##unbox %unbox
+CODEGEN: ##store-reg-param %store-reg-param
+CODEGEN: ##store-stack-param %store-stack-param
+CODEGEN: ##store-return %store-return
+CODEGEN: ##store-struct-return %store-struct-return
+CODEGEN: ##store-long-long-return %store-long-long-return
+CODEGEN: ##prepare-struct-area %prepare-struct-area
 CODEGEN: ##box %box
 CODEGEN: ##box-long-long %box-long-long
 CODEGEN: ##box-large-struct %box-large-struct
 CODEGEN: ##box-small-struct %box-small-struct
-CODEGEN: ##unbox %unbox
+CODEGEN: ##save-param-reg %save-param-reg
-CODEGEN: ##unbox-long-long %unbox-long-long
-CODEGEN: ##unbox-large-struct %unbox-large-struct
-CODEGEN: ##unbox-small-struct %unbox-small-struct
-CODEGEN: ##prepare-box-struct %prepare-box-struct
-CODEGEN: ##load-param-reg %load-param-reg
 CODEGEN: ##alien-invoke %alien-invoke
 CODEGEN: ##cleanup %cleanup
 CODEGEN: ##alien-indirect %alien-indirect
-CODEGEN: ##save-param-reg %save-param-reg
 CODEGEN: ##begin-callback %begin-callback
 CODEGEN: ##alien-callback %alien-callback
 CODEGEN: ##end-callback %end-callback

basis/compiler/tests/codegen.factor

@@ -472,3 +472,10 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-
     ] when ;
 
 [ ] [ 2000 [ "hello" clone dup gc-root-messup first eq? t assert= ] times ] unit-test
+
+! Alias analysis bug
+[ t ] [
+    [
+        10 10 <byte-array> [ <displaced-alien> underlying>> ] keep eq?
+    ] compile-call
+] unit-test

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -272,6 +272,11 @@ generic-comparison-ops [
     2drop alien \ f class-or <class-info>
 ] "outputs" set-word-prop
 
+\ <displaced-alien> [
+    [ interval>> 0 swap interval-contains? ] dip
+    class>> alien class-or alien ? <class-info>
+] "outputs" set-word-prop
+
 { <tuple> <tuple-boa> } [
     [
         literal>> dup array? [ first ] [ drop tuple ] if <class-info>

basis/compiler/tree/propagation/propagation-tests.factor

@@ -976,3 +976,22 @@ M: tuple-with-read-only-slot clone
     ! Should actually be 0 23 2^ 1 - [a,b]
     [ string-nth ] final-info first interval>> 0 23 2^ [a,b] =
 ] unit-test
+
+! Non-zero displacement for <displaced-alien> restricts the output type
+[ t ] [
+    [ { byte-array } declare <displaced-alien> ] final-classes
+    first byte-array alien class-or class=
+] unit-test
+
+[ V{ alien } ] [
+    [ { alien } declare <displaced-alien> ] final-classes
+] unit-test
+
+[ t ] [
+    [ { POSTPONE: f } declare <displaced-alien> ] final-classes
+    first \ f alien class-or class=
+] unit-test
+
+[ V{ alien } ] [
+    [ { byte-array } declare [ 10 bitand 2 + ] dip <displaced-alien> ] final-classes
+] unit-test

basis/cpu/architecture/architecture.factor

@@ -534,10 +534,6 @@ M: object immediate-comparand? ( n -- ? )
 : immediate-shift-count? ( n -- ? )
     0 cell-bits 1 - between? ;
 
-! What c-type describes the implicit struct return pointer for
-! large structs?
-HOOK: struct-return-pointer-type cpu ( -- c-type )
-
 ! Is this structure small enough to be returned in registers?
 HOOK: return-struct-in-registers? cpu ( c-type -- ? )
 
@@ -553,15 +549,30 @@ HOOK: dummy-int-params? cpu ( -- ? )
 ! If t, all int parameters are shadowed by dummy FP parameters
 HOOK: dummy-fp-params? cpu ( -- ? )
 
+! If t, long longs are never passed in param regs
+HOOK: long-long-on-stack? cpu ( -- ? )
+
+! If t, floats are never passed in param regs
+HOOK: float-on-stack? cpu ( -- ? )
+
+! If t, the struct return pointer is never passed in a param reg
+HOOK: struct-return-on-stack? cpu ( -- ? )
+
 ! Call a function to convert a tagged pointer into a value that
 ! can be passed to a C function, or returned from a callback
-HOOK: %unbox cpu ( src n rep func -- )
+HOOK: %unbox cpu ( dst src func rep -- )
 
-HOOK: %unbox-long-long cpu ( src n func -- )
+HOOK: %store-reg-param cpu ( src reg rep -- )
 
-HOOK: %unbox-small-struct cpu ( src c-type -- )
+HOOK: %store-stack-param cpu ( src n rep -- )
 
-HOOK: %unbox-large-struct cpu ( src n c-type -- )
+HOOK: %store-return cpu ( src rep -- )
+
+HOOK: %store-struct-return cpu ( src reps -- )
+
+HOOK: %store-long-long-return cpu ( src1 src2 -- )
+
+HOOK: %prepare-struct-area cpu ( dst -- )
 
 ! Call a function to convert a value into a tagged pointer,
 ! possibly allocating a bignum, float, or alien instance,
@@ -570,25 +581,21 @@ HOOK: %box cpu ( dst n rep func -- )
 
 HOOK: %box-long-long cpu ( dst n func -- )
 
-HOOK: %prepare-box-struct cpu ( -- )
-
 HOOK: %box-small-struct cpu ( dst c-type -- )
 
 HOOK: %box-large-struct cpu ( dst n c-type -- )
 
 HOOK: %save-param-reg cpu ( stack reg rep -- )
 
-HOOK: %load-param-reg cpu ( stack reg rep -- )
-
 HOOK: %restore-context cpu ( temp1 temp2 -- )
 
 HOOK: %save-context cpu ( temp1 temp2 -- )
 
 HOOK: %alien-invoke cpu ( function library -- )
 
-HOOK: %cleanup cpu ( params -- )
+HOOK: %cleanup cpu ( n -- )
 
-M: object %cleanup ( params -- ) drop ;
+M: object %cleanup ( n -- ) drop ;
 
 HOOK: %alien-indirect cpu ( src -- )
 
@@ -598,6 +605,6 @@ HOOK: %alien-callback cpu ( quot -- )
 
 HOOK: %end-callback cpu ( -- )
 
-HOOK: stack-cleanup cpu ( params -- n )
+HOOK: stack-cleanup cpu ( stack-size return abi -- n )
 
-M: object stack-cleanup drop 0 ;
+M: object stack-cleanup 3drop 0 ;

basis/cpu/ppc/ppc.factor

@@ -3,8 +3,8 @@
 USING: accessors assocs sequences kernel combinators
 classes.algebra byte-arrays make math math.order math.ranges
 system namespaces locals layouts words alien alien.accessors
-alien.c-types alien.complex alien.data literals cpu.architecture
+alien.c-types alien.complex alien.data alien.libraries
-cpu.ppc.assembler cpu.ppc.assembler.backend
+literals cpu.architecture cpu.ppc.assembler cpu.ppc.assembler.backend
 compiler.cfg.registers compiler.cfg.instructions
 compiler.cfg.comparisons compiler.codegen.fixup
 compiler.cfg.intrinsics compiler.cfg.stack-frame
@@ -681,13 +681,13 @@ GENERIC: load-param ( reg src -- )
 
 M: integer load-param int-rep %copy ;
 
-M: spill-slot load-param n>> spill@ LWZ ;
+M: spill-slot load-param [ 1 ] dip n>> spill@ LWZ ;
 
 GENERIC: store-param ( reg dst -- )
 
 M: integer store-param swap int-rep %copy ;
 
-M: spill-slot store-param n>> spill@ STW ;
+M: spill-slot store-param [ 1 ] dip n>> spill@ STW ;
 
 :: call-unbox-func ( src func -- )
     3 src load-param
@@ -710,7 +710,7 @@ M:: ppc %unbox-long-long ( src n func -- )
 M:: ppc %unbox-large-struct ( src n c-type -- )
     4 src load-param
     3 1 n local@ ADDI
-    heap-size 5 LI
+    c-type heap-size 5 LI
     "memcpy" "libc" load-library %alien-invoke ;
 
 M:: ppc %box ( dst n rep func -- )
@@ -724,6 +724,7 @@ M:: ppc %box-long-long ( dst n func -- )
         3 1 n local@ LWZ
         4 1 n cell + local@ LWZ
     ] when
+    5 %load-vm-addr
     func f %alien-invoke
     3 dst store-param ;
 
@@ -768,8 +769,6 @@ M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
 
 M: ppc immediate-store? drop f ;
 
-M: ppc struct-return-pointer-type void* ;
-
 M: ppc return-struct-in-registers? ( c-type -- ? )
     c-type return-in-registers?>> ;
 

basis/cpu/x86/32/32.factor

@@ -3,13 +3,10 @@
 USING: locals alien alien.c-types alien.libraries alien.syntax
 arrays kernel fry math namespaces sequences system layouts io
 vocabs.loader accessors init classes.struct combinators
-command-line make words compiler compiler.units
+make words compiler.constants compiler.codegen.fixup
-compiler.constants compiler.alien compiler.codegen
+compiler.cfg.instructions compiler.cfg.builder compiler.cfg.intrinsics
-compiler.codegen.fixup compiler.cfg.instructions
+compiler.cfg.stack-frame cpu.x86.assembler cpu.x86.assembler.operands
-compiler.cfg.builder compiler.cfg.builder.alien
+cpu.x86 cpu.architecture vm ;
-compiler.cfg.intrinsics compiler.cfg.stack-frame
-cpu.x86.assembler cpu.x86.assembler.operands cpu.x86
-cpu.architecture vm ;
 FROM: layouts => cell ;
 IN: cpu.x86.32
 
@@ -95,17 +92,14 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? )
     os { linux netbsd solaris } member? not
     and or ;
 
-: struct-return@ ( n -- operand )
+! On x86, parameters are usually never passed in registers,
-    [ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
+! except with Microsoft's "thiscall" and "fastcall" abis
-
-! On x86, parameters are usually never passed in registers, except with Microsoft's
-! "thiscall" and "fastcall" abis
 M: int-regs return-reg drop EAX ;
 M: float-regs param-regs 2drop { } ;
 
 M: int-regs param-regs
     nip {
-        { thiscall [ { ECX     } ] }
+        { thiscall [ { ECX } ] }
         { fastcall [ { ECX EDX } ] }
         [ drop { } ]
     } case ;
@@ -119,11 +113,37 @@ M: stack-params store-return-reg drop EAX MOV ;
 M: int-rep load-return-reg drop EAX swap MOV ;
 M: int-rep store-return-reg drop EAX MOV ;
 
-M: float-rep load-return-reg drop FLDS ;
+:: load-float-return ( src x87-insn sse-insn -- )
-M: float-rep store-return-reg drop FSTPS ;
+    src register? [
+        ESP 4 SUB
+        ESP [] src sse-insn execute
+        ESP [] x87-insn execute
+        ESP 4 ADD
+    ] [
+        src x87-insn execute
+    ] if ; inline
 
-M: double-rep load-return-reg drop FLDL ;
+:: store-float-return ( dst x87-insn sse-insn -- )
-M: double-rep store-return-reg drop FSTPL ;
+    dst register? [
+        ESP 4 SUB
+        ESP [] x87-insn execute
+        dst ESP [] sse-insn execute
+        ESP 4 ADD
+    ] [
+        dst x87-insn execute
+    ] if ; inline
+
+M: float-rep load-return-reg
+    drop \ FLDS \ MOVSS load-float-return ;
+
+M: float-rep store-return-reg
+    drop \ FSTPS \ MOVSS store-float-return ;
+
+M: double-rep load-return-reg
+    drop \ FLDL \ MOVSD load-float-return ;
+
+M: double-rep store-return-reg
+    drop \ FSTPL \ MOVSD store-float-return ;
 
 M: x86.32 %prologue ( n -- )
     dup PUSH
@@ -133,6 +153,29 @@ M: x86.32 %prologue ( n -- )
 M: x86.32 %prepare-jump
     pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
 
+:: call-unbox-func ( src func -- )
+    EAX src tagged-rep %copy
+    4 save-vm-ptr
+    0 stack@ EAX MOV
+    func f %alien-invoke ;
+
+M:: x86.32 %unbox ( dst src func rep -- )
+    src func call-unbox-func
+    dst ?spill-slot rep store-return-reg ;
+
+M:: x86.32 %store-return ( src rep -- )
+    src ?spill-slot rep load-return-reg ;
+
+M:: x86.32 %store-long-long-return ( src1 src2 -- )
+    src2 EAX = [ src1 src2 XCHG src2 src1 ] [ src1 src2 ] if :> ( src1 src2 )
+    EAX src1 int-rep %copy
+    EDX src2 int-rep %copy ;
+
+M:: x86.32 %store-struct-return ( src c-type -- )
+    EAX src int-rep %copy
+    EDX EAX 4 [+] MOV
+    EAX EAX [] MOV ;
+
 M: stack-params copy-register*
     drop
     {
@@ -142,8 +185,6 @@ M: stack-params copy-register*
 
 M: x86.32 %save-param-reg [ local@ ] 2dip %copy ;
 
-M: x86.32 %load-param-reg [ swap local@ ] dip %copy ;
-
 : (%box) ( n rep -- )
     #! If n is f, push the return register onto the stack; we
     #! are boxing a return value of a C function. If n is an
@@ -172,6 +213,9 @@ M:: x86.32 %box-long-long ( dst n func -- )
     func f %alien-invoke
     dst EAX tagged-rep %copy ;
 
+M: x86.32 struct-return@ ( n -- operand )
+    [ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
+
 M:: x86.32 %box-large-struct ( dst n c-type -- )
     EDX n struct-return@ LEA
     8 save-vm-ptr
@@ -180,12 +224,6 @@ M:: x86.32 %box-large-struct ( dst n c-type -- )
     "from_value_struct" f %alien-invoke
     dst EAX tagged-rep %copy ;
 
-M: x86.32 %prepare-box-struct ( -- )
-    ! Compute target address for value struct return
-    EAX f struct-return@ LEA
-    ! Store it as the first parameter
-    0 local@ EAX MOV ;
-
 M:: x86.32 %box-small-struct ( dst c-type -- )
     #! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
     12 save-vm-ptr
@@ -195,46 +233,6 @@ M:: x86.32 %box-small-struct ( dst c-type -- )
     "from_small_struct" f %alien-invoke
     dst EAX tagged-rep %copy ;
 
-:: call-unbox-func ( src func -- )
-    EAX src tagged-rep %copy
-    4 save-vm-ptr
-    0 stack@ EAX MOV
-    func f %alien-invoke ;
-
-M:: x86.32 %unbox ( src n rep func -- )
-    ! If n is f, we're unboxing a return value about to be
-    ! returned by the callback. Otherwise, we're unboxing
-    ! a parameter to a C function about to be called.
-    src func call-unbox-func
-    ! Store the return value on the C stack
-    n [ n local@ rep store-return-reg ] when ;
-
-M:: x86.32 %unbox-long-long ( src n func -- )
-    src func call-unbox-func
-    ! Store the return value on the C stack
-    n [
-        [ local@ EAX MOV ]
-        [ 4 + local@ EDX MOV ] bi
-    ] when* ;
-
-M: x86 %unbox-small-struct ( src size -- )
-    [ [ EAX ] dip int-rep %copy ]
-    [
-        heap-size 4 > [ EDX EAX 4 [+] MOV ] when
-        EAX EAX [] MOV
-    ] bi* ;
-
-M:: x86.32 %unbox-large-struct ( src n c-type -- )
-    EAX src int-rep %copy
-    EDX n local@ LEA
-    8 stack@ c-type heap-size MOV
-    4 stack@ EAX MOV
-    0 stack@ EDX MOV
-    "memcpy" "libc" load-library %alien-invoke ;
-
-M: x86.32 %alien-indirect ( src -- )
-    ?spill-slot CALL ;
-
 M: x86.32 %begin-callback ( -- )
     0 save-vm-ptr
     4 stack@ 0 MOV
@@ -277,32 +275,23 @@ M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
     func "libm" load-library %alien-invoke
     dst float-function-return ;
 
-: funny-large-struct-return? ( params -- ? )
+: funny-large-struct-return? ( return abi -- ? )
     #! MINGW ABI incompatibility disaster
-    [ return>> large-struct? ]
+    [ large-struct? ] [ mingw eq? os windows? not or ] bi* and ;
-    [ abi>> mingw = os windows? not or ]
-    bi and ;
 
-: stack-arg-size ( params -- n )
+M:: x86.32 stack-cleanup ( stack-size return abi -- n )
-    dup abi>> '[
-        alien-parameters flatten-c-types
-        [ _ alloc-parameter 2drop ] each
-        stack-params get
-    ] with-param-regs ;
-
-M: x86.32 stack-cleanup ( params -- n )
     #! a) Functions which are stdcall/fastcall/thiscall have to
     #! clean up the caller's stack frame.
     #! b) Functions returning large structs on MINGW have to
     #! fix ESP.
     {
-        { [ dup abi>> callee-cleanup? ] [ stack-arg-size ] }
+        { [ abi callee-cleanup? ] [ stack-size ] }
-        { [ dup funny-large-struct-return? ] [ drop 4 ] }
+        { [ return abi funny-large-struct-return? ] [ 4 ] }
-        [ drop 0 ]
+        [ 0 ]
     } cond ;
 
-M: x86.32 %cleanup ( params -- )
+M: x86.32 %cleanup ( n -- )
-    stack-cleanup [ ESP swap SUB ] unless-zero ;
+    [ ESP swap SUB ] unless-zero ;
 
 M:: x86.32 %call-gc ( gc-roots -- )
     4 save-vm-ptr
@@ -315,12 +304,13 @@ M: x86.32 dummy-int-params? f ;
 
 M: x86.32 dummy-fp-params? f ;
 
-! Dreadful
+M: x86.32 long-long-on-stack? t ;
-M: struct-c-type flatten-c-type stack-params (flatten-c-type) ;
-M: long-long-type flatten-c-type stack-params (flatten-c-type) ;
-M: c-type flatten-c-type dup rep>> int-rep? int-rep stack-params ? (flatten-c-type) ;
 
-M: x86.32 struct-return-pointer-type
+M: x86.32 float-on-stack? t ;
-    os linux? void* (stack-value) ? ;
+
+M: x86.32 flatten-struct-type
+    stack-size cell /i { int-rep t } <repetition> ;
+
+M: x86.32 struct-return-on-stack? os linux? not ;
 
 check-sse

basis/cpu/x86/64/64.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel math namespaces make sequences
 system layouts alien alien.c-types alien.accessors alien.libraries
-slots splitting assocs combinators locals compiler.constants
+slots splitting assocs combinators fry locals compiler.constants
 classes.struct compiler.codegen compiler.codegen.fixup
 compiler.cfg.instructions compiler.cfg.builder
 compiler.cfg.intrinsics compiler.cfg.stack-frame
@@ -99,6 +99,39 @@ M:: x86.64 %dispatch ( src temp -- )
     [ (align-code) ]
     bi ;
 
+M:: x86.64 %unbox ( dst src func rep -- )
+    param-reg-0 src tagged-rep %copy
+    param-reg-1 %mov-vm-ptr
+    func f %alien-invoke
+    dst rep reg-class-of return-reg rep %copy ;
+
+: with-return-regs ( quot -- )
+    [
+        V{ RDX RAX } clone int-regs set
+        V{ XMM1 XMM0 } clone float-regs set
+        call
+    ] with-scope ; inline
+
+: each-struct-component ( c-type quot -- )
+    '[
+        flatten-struct-type
+        [ [ first ] dip @ ] each-index
+    ] with-return-regs ; inline
+
+: %unbox-struct-component ( rep i -- )
+    R11 swap cells [+] swap reg-class-of {
+        { int-regs [ int-regs get pop swap MOV ] }
+        { float-regs [ float-regs get pop swap MOVSD ] }
+    } case ;
+
+M:: x86.64 %store-return ( src rep -- )
+    rep reg-class-of return-reg src rep %copy ;
+
+M:: x86.64 %store-struct-return ( src c-type -- )
+    ! Move src to R11 so that we don't clobber it.
+    R11 src int-rep %copy
+    c-type [ %unbox-struct-component ] each-struct-component ;
+
 M: stack-params copy-register*
     drop
     {
@@ -108,84 +141,32 @@ M: stack-params copy-register*
 
 M: x86.64 %save-param-reg [ param@ ] 2dip %copy ;
 
-M: x86.64 %load-param-reg [ swap param@ ] dip %copy ;
-
-: with-return-regs ( quot -- )
-    [
-        V{ RDX RAX } clone int-regs set
-        V{ XMM1 XMM0 } clone float-regs set
-        call
-    ] with-scope ; inline
-
-M:: x86.64 %unbox ( src n rep func -- )
-    param-reg-0 src tagged-rep %copy
-    param-reg-1 %mov-vm-ptr
-    ! Call the unboxer
-    func f %alien-invoke
-    ! Store the return value on the C stack if this is an
-    ! alien-invoke, otherwise leave it the return register if
-    ! this is the end of alien-callback
-    n [ n rep reg-class-of return-reg rep %save-param-reg ] when ;
-
-: %unbox-struct-field ( rep i -- )
-    R11 swap cells [+] swap reg-class-of {
-        { int-regs [ int-regs get pop swap MOV ] }
-        { float-regs [ float-regs get pop swap MOVSD ] }
-    } case ;
-
-M:: x86.64 %unbox-small-struct ( src c-type -- )
-    ! Move src to R11 so that we don't clobber it.
-    R11 src int-rep %copy
-    [
-        c-type flatten-struct-type
-        [ %unbox-struct-field ] each-index
-    ] with-return-regs ;
-
-M:: x86.64 %unbox-large-struct ( src n c-type -- )
-    param-reg-1 src int-rep %copy
-    param-reg-0 n param@ LEA
-    param-reg-2 c-type heap-size MOV
-    "memcpy" "libc" load-library %alien-invoke ;
-
-: load-return-value ( rep -- )
-    [ [ 0 ] dip reg-class-of cdecl param-reg ]
-    [ reg-class-of return-reg ]
-    [ ]
-    tri %copy ;
-
 M:: x86.64 %box ( dst n rep func -- )
-    n [
+    0 rep reg-class-of cdecl param-reg
-        n
+    n [ n param@ ] [ rep reg-class-of return-reg ] if rep %copy
-        0 rep reg-class-of cdecl param-reg
-        rep %load-param-reg
-    ] [
-        rep load-return-value
-    ] if
     rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
     func f %alien-invoke
     dst RAX tagged-rep %copy ;
 
-: box-struct-field@ ( i -- operand ) 1 + cells param@ ;
+: box-struct-component@ ( i -- operand ) 1 + cells param@ ;
 
-: %box-struct-field ( rep i -- )
+: %box-struct-component ( rep i -- )
-    box-struct-field@ swap reg-class-of {
+    box-struct-component@ swap reg-class-of {
         { int-regs [ int-regs get pop MOV ] }
         { float-regs [ float-regs get pop MOVSD ] }
     } case ;
 
 M:: x86.64 %box-small-struct ( dst c-type -- )
     #! Box a <= 16-byte struct.
-    [
+    c-type [ %box-struct-component ] each-struct-component
-        c-type flatten-struct-type [ %box-struct-field ] each-index
+    param-reg-2 c-type heap-size MOV
-        param-reg-2 c-type heap-size MOV
+    param-reg-0 0 box-struct-component@ MOV
-        param-reg-0 0 box-struct-field@ MOV
+    param-reg-1 1 box-struct-component@ MOV
-        param-reg-1 1 box-struct-field@ MOV
+    param-reg-3 %mov-vm-ptr
-        param-reg-3 %mov-vm-ptr
+    "from_small_struct" f %alien-invoke
-        "from_small_struct" f %alien-invoke
+    dst RAX tagged-rep %copy ;
-        dst RAX tagged-rep %copy
-    ] with-return-regs ;
 
-: struct-return@ ( n -- operand )
+M: x86.64 struct-return@ ( n -- operand )
     [ stack-frame get params>> ] unless* param@ ;
 
 M:: x86.64 %box-large-struct ( dst n c-type -- )
@@ -198,20 +179,11 @@ M:: x86.64 %box-large-struct ( dst n c-type -- )
     "from_value_struct" f %alien-invoke
     dst RAX tagged-rep %copy ;
 
-M: x86.64 %prepare-box-struct ( -- )
-    ! Compute target address for value struct return
-    RAX f struct-return@ LEA
-    ! Store it as the first parameter
-    0 param@ RAX MOV ;
-
 M: x86.64 %alien-invoke
     R11 0 MOV
     rc-absolute-cell rel-dlsym
     R11 CALL ;
 
-M: x86.64 %alien-indirect ( src -- )
-    ?spill-slot CALL ;
-
 M: x86.64 %begin-callback ( -- )
     param-reg-0 %mov-vm-ptr
     param-reg-1 0 MOV
@@ -249,7 +221,11 @@ M:: x86.64 %call-gc ( gc-roots -- )
     param-reg-1 %mov-vm-ptr
     "inline_gc" f %alien-invoke ;
 
-M: x86.64 struct-return-pointer-type void* ;
+M: x86.64 long-long-on-stack? f ;
+
+M: x86.64 float-on-stack? f ;
+
+M: x86.64 struct-return-on-stack? f ;
 
 ! The result of reading 4 bytes from memory is a fixnum on
 ! x86-64.

basis/cpu/x86/64/unix/unix.factor

@@ -28,10 +28,11 @@ M: x86.64 reserved-stack-space 0 ;
     struct-types&offset split-struct [
         [ c-type c-type-rep reg-class-of ] map
         int-regs swap member? int-rep double-rep ?
+        f 2array
     ] map ;
 
 : flatten-large-struct ( c-type -- seq )
-    stack-params (flatten-c-type) ;
+    stack-size cell /i { int-rep t } <repetition> ;
 
 M: x86.64 flatten-struct-type ( c-type -- seq )
     dup heap-size 16 >

basis/cpu/x86/x86.factor

@@ -1443,10 +1443,28 @@ M: x86.64 %scalar>integer ( dst src rep -- )
     } case ;
 
 M: x86 %vector>scalar %copy ;
+
 M: x86 %scalar>vector %copy ;
 
-M:: x86 %spill ( src rep dst -- ) dst src rep %copy ;
+M:: x86 %spill ( src rep dst -- )
-M:: x86 %reload ( dst rep src -- ) dst src rep %copy ;
+    dst src rep %copy ;
+
+M:: x86 %reload ( dst rep src -- )
+    dst src rep %copy ;
+
+M:: x86 %store-reg-param ( src reg rep -- )
+    reg src rep %copy ;
+
+M:: x86 %store-stack-param ( src n rep -- )
+    n param@ src rep %copy ;
+
+HOOK: struct-return@ cpu ( n -- operand )
+
+M: x86 %prepare-struct-area ( dst -- )
+    f struct-return@ LEA ;
+
+M: x86 %alien-indirect ( src -- )
+    ?spill-slot CALL ;
 
 M: x86 %loop-entry 16 alignment [ NOP ] times ;
 

basis/stack-checker/alien/alien.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences accessors combinators math namespaces
 init sets words assocs alien.libraries alien alien.private
-alien.c-types cpu.architecture fry stack-checker.backend
+alien.c-types fry stack-checker.backend
 stack-checker.errors stack-checker.visitor
 stack-checker.dependencies ;
 IN: stack-checker.alien
@@ -98,11 +98,11 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
     ! Quotation which coerces return value to required type
     infer-return ;
 
-: callback-xt ( word return-rewind -- alien )
+: callback-xt ( word -- alien )
-    [ callbacks get ] dip '[ _ <callback> ] cache ;
+    callbacks get [ dup "stack-cleanup" word-prop <callback> ] cache ;
 
 : callback-bottom ( params -- )
-    [ xt>> ] [ stack-cleanup ] bi '[ _ _ callback-xt ] infer-quot-here ;
+    xt>> '[ _ callback-xt ] infer-quot-here ;
 
 : infer-alien-callback ( -- )
     alien-callback-params new

basis/x11/x11.factor

@@ -3,6 +3,7 @@
 USING: alien.strings continuations io
 io.encodings.ascii kernel namespaces x11.xlib x11.io
 vocabs vocabs.loader ;
+FROM: alien.c-types => c-bool> ;
 IN: x11
 
 SYMBOL: dpy
@@ -11,7 +12,7 @@ SYMBOL: root
 
 : init-locale ( -- )
    LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless
-   XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ;
+   XSupportsLocale c-bool> [ "XSupportsLocale() failed" print flush ] unless ;
 
 : flush-dpy ( -- ) dpy get XFlush drop ;
 

extra/cuda/constants/constants.factor

@@ -1,4 +0,0 @@
-IN: cuda.constants
-
-CONSTANT: cuda-shared-size 16384
-CONSTANT: cuda-warp-size 32

extra/cuda/cuda.factor

@@ -5,9 +5,9 @@ alien.syntax arrays assocs byte-arrays classes.struct
 combinators continuations cuda.ffi cuda.memory cuda.utils
 destructors fry init io io.backend io.encodings.string
 io.encodings.utf8 kernel lexer locals macros math math.parser
-namespaces nested-comments opengl.gl.extensions parser
+namespaces opengl.gl.extensions parser prettyprint quotations
-prettyprint quotations sequences words cuda.libraries ;
+sequences words cuda.libraries ;
-QUALIFIED-WITH: alien.c-types a
+QUALIFIED-WITH: alien.c-types c
 IN: cuda
 
 TUPLE: launcher
@@ -41,11 +41,11 @@ dim-grid dim-block shared-size stream ;
 
 : c-type>cuda-setter ( c-type -- n cuda-type )
     {
-        { [ dup a:int = ] [ drop 4 [ cuda-int* ] ] }
+        { [ dup c:int = ] [ drop 4 [ cuda-int* ] ] }
-        { [ dup a:uint = ] [ drop 4 [ cuda-int* ] ] }
+        { [ dup c:uint = ] [ drop 4 [ cuda-int* ] ] }
-        { [ dup a:float = ] [ drop 4 [ cuda-float* ] ] }
+        { [ dup c:float = ] [ drop 4 [ cuda-float* ] ] }
-        { [ dup a:pointer? ] [ drop 4 [ cuda-int* ] ] }
+        { [ dup c:pointer? ] [ drop 4 [ cuda-int* ] ] }
-        { [ dup a:void* = ] [ drop 4 [ cuda-int* ] ] }
+        { [ dup c:void* = ] [ drop 4 [ cuda-int* ] ] }
     } cond ;
 
 <PRIVATE
@@ -85,5 +85,5 @@ MACRO: cuda-arguments ( c-types -- quot: ( args... function -- ) )
             [ run-function-launcher ] 2bi
         ]
     ]
-    [ 2nip \ function-launcher suffix a:void function-effect ]
+    [ 2nip \ function-launcher suffix c:void function-effect ]
     3bi define-declared ;

extra/cuda/devices/devices-tests.factor

@@ -0,0 +1,13 @@
+! (c)2010 Joe Groff bsd license
+USING: cuda.devices tools.test ;
+IN: cuda.devices.tests
+
+[ 1  5 100 ] [  5 20 100 10 (distribute-jobs) ] unit-test 
+[ 2  5 100 ] [ 10 20 100 10 (distribute-jobs) ] unit-test 
+[ 2  5 100 ] [ 10 20 200  5 (distribute-jobs) ] unit-test 
+[ 2  5 100 ] [ 10 20 300  6 (distribute-jobs) ] unit-test 
+[ 2  6 120 ] [ 11 20 300  6 (distribute-jobs) ] unit-test 
+[ 1 10 200 ] [ 10 20 200 10 (distribute-jobs) ] unit-test 
+[ 1 10   0 ] [ 10  0 200 10 (distribute-jobs) ] unit-test 
+[ 2  5   0 ] [ 10  0 200  9 (distribute-jobs) ] unit-test 
+

extra/cuda/devices/devices.factor

@@ -1,17 +1,15 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.data alien.strings arrays assocs
+USING: accessors alien.c-types alien.data alien.strings arrays
-byte-arrays classes.struct combinators cuda cuda.ffi cuda.utils
+assocs byte-arrays classes.struct combinators cuda cuda.ffi
-fry io io.encodings.utf8 kernel math.parser prettyprint
+cuda.syntax cuda.utils fry io io.encodings.utf8 kernel locals
-sequences ;
+math math.order math.parser namespaces prettyprint sequences ;
 IN: cuda.devices
 
 : #cuda-devices ( -- n )
-    init-cuda
     int <c-object> [ cuDeviceGetCount cuda-error ] keep *int ;
 
 : n>cuda-device ( n -- device )
-    init-cuda
     [ CUdevice <c-object> ] dip [ cuDeviceGet cuda-error ] 2keep drop *int ;
 
 : enumerate-cuda-devices ( -- devices )
@@ -21,40 +19,33 @@ IN: cuda.devices
     [ enumerate-cuda-devices ] dip '[ <launcher> _ with-cuda ] each ; inline
 
 : cuda-device-properties ( n -- properties )
-    init-cuda
+    [ CUdevprop <struct> ] dip
-    [ CUdevprop <c-object> ] dip
+    [ cuDeviceGetProperties cuda-error ] 2keep drop ;
-    [ cuDeviceGetProperties cuda-error ] 2keep drop
-    CUdevprop memory>struct ;
 
 : cuda-devices ( -- assoc )
     enumerate-cuda-devices [ dup cuda-device-properties ] { } map>assoc ;
 
 : cuda-device-name ( n -- string )
-    init-cuda
     [ 256 [ <byte-array> ] keep ] dip
     [ cuDeviceGetName cuda-error ]
     [ 2drop utf8 alien>string ] 3bi ;
 
 : cuda-device-capability ( n -- pair )
-    init-cuda
     [ int <c-object> int <c-object> ] dip
     [ cuDeviceComputeCapability cuda-error ]
     [ drop [ *int ] bi@ ] 3bi 2array ;
 
 : cuda-device-memory ( n -- bytes )
-    init-cuda
     [ uint <c-object> ] dip
     [ cuDeviceTotalMem cuda-error ]
     [ drop *uint ] 2bi ;
 
 : cuda-device-attribute ( attribute n -- n )
-    init-cuda
     [ int <c-object> ] 2dip
     [ cuDeviceGetAttribute cuda-error ]
     [ 2drop *int ] 3bi ;
 
 : cuda-device. ( n -- )
-    init-cuda
     {
         [ "Device: " write number>string print ]
         [ "Name: " write cuda-device-name print ]
@@ -76,3 +67,20 @@ IN: cuda.devices
     "CUDA Version: " write cuda-version number>string print nl
     #cuda-devices iota [ nl ] [ cuda-device. ] interleave ;
 
+: up/i ( x y -- z )
+    [ 1 - + ] keep /i ; inline
+
+:: (distribute-jobs) ( job-count per-job-shared max-shared-size max-block-size
+                       -- grid-size block-size per-block-shared )
+    per-job-shared [ max-block-size ] [ max-shared-size swap /i max-block-size min ] if-zero
+        job-count min :> job-max-block-size
+    job-count job-max-block-size up/i :> grid-size
+    job-count grid-size up/i          :> block-size
+    block-size per-job-shared *       :> per-block-shared
+
+    grid-size block-size per-block-shared ; inline
+
+: distribute-jobs ( job-count per-job-shared -- launcher )
+    cuda-device get cuda-device-properties 
+    [ sharedMemPerBlock>> ] [ maxThreadsDim>> first ] bi
+    (distribute-jobs) 3<<< ; inline

extra/cuda/types/types.factor

@@ -0,0 +1,292 @@
+! (c)2010 Joe Groff bsd license
+USING: accessors alien.c-types classes.struct kernel math ;
+FROM: alien.c-types => float ;
+IN: cuda.types
+
+STRUCT: char1
+    { x char } ;
+STRUCT: char2
+    { x char }
+    { y char } ;
+STRUCT: char3
+    { x char }
+    { y char }
+    { z char } ;
+STRUCT: char4
+    { x char }
+    { y char }
+    { z char }
+    { w char } ;
+
+STRUCT: uchar1
+    { x uchar } ;
+STRUCT: uchar2
+    { x uchar }
+    { y uchar } ;
+STRUCT: uchar3
+    { x uchar }
+    { y uchar }
+    { z uchar } ;
+STRUCT: uchar4
+    { x uchar }
+    { y uchar }
+    { z uchar }
+    { w uchar } ;
+
+STRUCT: short1
+    { x short } ;
+STRUCT: short2
+    { x short }
+    { y short } ;
+STRUCT: short3
+    { x short }
+    { y short }
+    { z short } ;
+STRUCT: short4
+    { x short }
+    { y short }
+    { z short }
+    { w short } ;
+
+STRUCT: ushort1
+    { x ushort } ;
+STRUCT: ushort2
+    { x ushort }
+    { y ushort } ;
+STRUCT: ushort3
+    { x ushort }
+    { y ushort }
+    { z ushort } ;
+STRUCT: ushort4
+    { x ushort }
+    { y ushort }
+    { z ushort }
+    { w ushort } ;
+
+STRUCT: int1
+    { x int } ;
+STRUCT: int2
+    { x int }
+    { y int } ;
+STRUCT: int3
+    { x int }
+    { y int }
+    { z int } ;
+STRUCT: int4
+    { x int }
+    { y int }
+    { z int }
+    { w int } ;
+
+STRUCT: uint1
+    { x uint } ;
+STRUCT: uint2
+    { x uint }
+    { y uint } ;
+STRUCT: uint3
+    { x uint }
+    { y uint }
+    { z uint } ;
+STRUCT: uint4
+    { x uint }
+    { y uint }
+    { z uint }
+    { w uint } ;
+
+STRUCT: long1
+    { x long } ;
+STRUCT: long2
+    { x long }
+    { y long } ;
+STRUCT: long3
+    { x long }
+    { y long }
+    { z long } ;
+STRUCT: long4
+    { x long }
+    { y long }
+    { z long }
+    { w long } ;
+
+STRUCT: ulong1
+    { x ulong } ;
+STRUCT: ulong2
+    { x ulong }
+    { y ulong } ;
+STRUCT: ulong3
+    { x ulong }
+    { y ulong }
+    { z ulong } ;
+STRUCT: ulong4
+    { x ulong }
+    { y ulong }
+    { z ulong }
+    { w ulong } ;
+
+STRUCT: longlong1
+    { x longlong } ;
+STRUCT: longlong2
+    { x longlong }
+    { y longlong } ;
+STRUCT: longlong3
+    { x longlong }
+    { y longlong }
+    { z longlong } ;
+STRUCT: longlong4
+    { x longlong }
+    { y longlong }
+    { z longlong }
+    { w longlong } ;
+
+STRUCT: ulonglong1
+    { x ulonglong } ;
+STRUCT: ulonglong2
+    { x ulonglong }
+    { y ulonglong } ;
+STRUCT: ulonglong3
+    { x ulonglong }
+    { y ulonglong }
+    { z ulonglong } ;
+STRUCT: ulonglong4
+    { x ulonglong }
+    { y ulonglong }
+    { z ulonglong }
+    { w ulonglong } ;
+
+STRUCT: float1
+    { x float } ;
+STRUCT: float2
+    { x float }
+    { y float } ;
+STRUCT: float3
+    { x float }
+    { y float }
+    { z float } ;
+STRUCT: float4
+    { x float }
+    { y float }
+    { z float }
+    { w float } ;
+
+STRUCT: double1
+    { x double } ;
+STRUCT: double2
+    { x double }
+    { y double } ;
+STRUCT: double3
+    { x double }
+    { y double }
+    { z double } ;
+STRUCT: double4
+    { x double }
+    { y double }
+    { z double }
+    { w double } ;
+
+char2 c-type 
+    2 >>align
+    2 >>align-first
+    drop
+char4 c-type 
+    4 >>align
+    4 >>align-first
+    drop
+
+uchar2 c-type 
+    2 >>align
+    2 >>align-first
+    drop
+uchar4 c-type 
+    4 >>align
+    4 >>align-first
+    drop
+
+short2 c-type 
+    4 >>align
+    4 >>align-first
+    drop
+short4 c-type 
+    8 >>align
+    8 >>align-first
+    drop
+
+ushort2 c-type 
+    4 >>align
+    4 >>align-first
+    drop
+ushort4 c-type 
+    8 >>align
+    8 >>align-first
+    drop
+
+int2 c-type 
+    8 >>align
+    8 >>align-first
+    drop
+int4 c-type 
+    16 >>align
+    16 >>align-first
+    drop
+
+uint2 c-type 
+    8 >>align
+    8 >>align-first
+    drop
+uint4 c-type 
+    16 >>align
+    16 >>align-first
+    drop
+
+long2 c-type 
+    long heap-size 2 * >>align
+    long heap-size 2 * >>align-first
+    drop
+long4 c-type 
+    16 >>align
+    16 >>align-first
+    drop
+
+ulong2 c-type 
+    long heap-size 2 * >>align
+    long heap-size 2 * >>align-first
+    drop
+ulong4 c-type 
+    16 >>align
+    16 >>align-first
+    drop
+
+longlong2 c-type 
+    16 >>align
+    16 >>align-first
+    drop
+longlong4 c-type 
+    16 >>align
+    16 >>align-first
+    drop
+
+ulonglong2 c-type 
+    16 >>align
+    16 >>align-first
+    drop
+ulonglong4 c-type 
+    16 >>align
+    16 >>align-first
+    drop
+
+float2 c-type 
+    8 >>align
+    8 >>align-first
+    drop
+float4 c-type 
+    16 >>align
+    16 >>align-first
+    drop
+
+double2 c-type 
+    16 >>align
+    16 >>align-first
+    drop
+double4 c-type 
+    16 >>align
+    16 >>align-first
+    drop

extra/cuda/utils/utils.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types alien.data alien.strings arrays
-assocs byte-arrays classes.struct combinators cuda.ffi io
+assocs byte-arrays classes.struct combinators cuda.ffi
-io.backend io.encodings.utf8 kernel math.parser namespaces
+io io.backend io.encodings.utf8 kernel math.parser namespaces
 prettyprint sequences ;
 IN: cuda.utils
 
@@ -21,7 +21,7 @@ ERROR: throw-cuda-error n ;
     dup CUDA_SUCCESS = [ drop ] [ throw-cuda-error ] if ;
 
 : init-cuda ( -- )
-    0 cuInit cuda-error ;
+    0 cuInit cuda-error ; inline
 
 : cuda-version ( -- n )
     int <c-object> [ cuDriverGetVersion cuda-error ] keep *int ;
@@ -40,55 +40,58 @@ ERROR: throw-cuda-error n ;
 
 : create-context ( flags device -- context )
     [ CUcontext <c-object> ] 2dip
-    [ cuCtxCreate cuda-error ] 3keep 2drop *void* ;
+    [ cuCtxCreate cuda-error ] 3keep 2drop *void* ; inline
 
-: destroy-context ( context -- ) cuCtxDestroy cuda-error ;
+: sync-context ( -- )
+    cuCtxSynchronize cuda-error ; inline
 
-: launch-function* ( function -- ) cuLaunch cuda-error ;
+: destroy-context ( context -- ) cuCtxDestroy cuda-error ; inline
 
-: launch-function ( -- ) cuda-function get cuLaunch cuda-error ;
+: launch-function* ( function -- ) cuLaunch cuda-error ; inline
+
+: launch-function ( -- ) cuda-function get cuLaunch cuda-error ; inline
 
 : cuda-int* ( function offset value -- )
-    cuParamSeti cuda-error ;
+    cuParamSeti cuda-error ; inline
 
 : cuda-int ( offset value -- )
-    [ cuda-function get ] 2dip cuda-int* ;
+    [ cuda-function get ] 2dip cuda-int* ; inline
 
 : cuda-float* ( function offset value -- )
-    cuParamSetf cuda-error ;
+    cuParamSetf cuda-error ; inline
 
 : cuda-float ( offset value -- )
-    [ cuda-function get ] 2dip cuda-float* ;
+    [ cuda-function get ] 2dip cuda-float* ; inline
 
 : cuda-vector* ( function offset ptr n -- )
-    cuParamSetv cuda-error ;
+    cuParamSetv cuda-error ; inline
 
 : cuda-vector ( offset ptr n -- )
-    [ cuda-function get ] 3dip cuda-vector* ;
+    [ cuda-function get ] 3dip cuda-vector* ; inline
 
 : param-size* ( function n -- )
-    cuParamSetSize cuda-error ;
+    cuParamSetSize cuda-error ; inline
 
 : param-size ( n -- )
-    [ cuda-function get ] dip param-size* ;
+    [ cuda-function get ] dip param-size* ; inline
 
 : launch-function-grid* ( function width height -- )
-    cuLaunchGrid cuda-error ;
+    cuLaunchGrid cuda-error ; inline
 
 : launch-function-grid ( width height -- )
     [ cuda-function get ] 2dip
-    cuLaunchGrid cuda-error ;
+    cuLaunchGrid cuda-error ; inline
 
 : function-block-shape* ( function x y z -- )
-    cuFuncSetBlockShape cuda-error ;
+    cuFuncSetBlockShape cuda-error ; inline
 
 : function-block-shape ( x y z -- )
     [ cuda-function get ] 3dip
-    cuFuncSetBlockShape cuda-error ;
+    cuFuncSetBlockShape cuda-error ; inline
 
 : function-shared-size* ( function n -- )
-    cuFuncSetSharedSize cuda-error ;
+    cuFuncSetSharedSize cuda-error ; inline
 
 : function-shared-size ( n -- )
     [ cuda-function get ] dip
-    cuFuncSetSharedSize cuda-error ;
+    cuFuncSetSharedSize cuda-error ; inline

vm/alien.cpp

@@ -104,12 +104,12 @@ void *factor_vm::alien_pointer()
 #define DEFINE_ALIEN_ACCESSOR(name,type,from,to) \
 	VM_C_API void primitive_alien_##name(factor_vm *parent) \
 	{ \
-		parent->ctx->push(from(*(type*)(parent->alien_pointer()),parent)); \
+		parent->ctx->push(parent->from(*(type*)(parent->alien_pointer()))); \
 	} \
 	VM_C_API void primitive_set_alien_##name(factor_vm *parent) \
 	{ \
 		type *ptr = (type *)parent->alien_pointer(); \
-		type value = (type)to(parent->ctx->pop(),parent); \
+		type value = (type)parent->to(parent->ctx->pop()); \
 		*ptr = value; \
 	}
 

vm/contexts.hpp

@@ -36,6 +36,9 @@ struct context {
 	set-context-object primitives */
 	cell context_objects[context_object_count];
 
+	/* temporary area used by FFI code generation */
+	s64 long_long_return;
+
 	context(cell datastack_size, cell retainstack_size, cell callstack_size);
 	~context();
 

vm/math.cpp

@@ -491,9 +491,10 @@ s64 factor_vm::to_signed_8(cell obj)
 	}
 }
 
-VM_C_API s64 to_signed_8(cell obj, factor_vm *parent)
+VM_C_API s64 *to_signed_8(cell obj, factor_vm *parent)
 {
-	return parent->to_signed_8(obj);
+	parent->ctx->long_long_return = parent->to_signed_8(obj);
+	return &parent->ctx->long_long_return;
 }
 
 cell factor_vm::from_unsigned_8(u64 n)
@@ -524,9 +525,10 @@ u64 factor_vm::to_unsigned_8(cell obj)
 	}
 }
 
-VM_C_API u64 to_unsigned_8(cell obj, factor_vm *parent)
+VM_C_API s64 *to_unsigned_8(cell obj, factor_vm *parent)
 {
-	return parent->to_unsigned_8(obj);
+	parent->ctx->long_long_return = parent->to_unsigned_8(obj);
+	return &parent->ctx->long_long_return;
 }
  
 VM_C_API cell from_float(float flo, factor_vm *parent)

vm/math.hpp

@@ -90,8 +90,8 @@ VM_C_API cell from_unsigned_cell(cell integer, factor_vm *vm);
 VM_C_API cell from_signed_8(s64 n, factor_vm *vm);
 VM_C_API cell from_unsigned_8(u64 n, factor_vm *vm);
 
-VM_C_API s64 to_signed_8(cell obj, factor_vm *vm);
+VM_C_API s64 *to_signed_8(cell obj, factor_vm *vm);
-VM_C_API u64 to_unsigned_8(cell obj, factor_vm *vm);
+VM_C_API s64 *to_unsigned_8(cell obj, factor_vm *vm);
 
 VM_C_API fixnum to_fixnum(cell tagged, factor_vm *vm);
 VM_C_API cell to_cell(cell tagged, factor_vm *vm);

vm/primitives.hpp

@@ -145,8 +145,8 @@ namespace factor
 	_(unsigned_2,u16,from_unsigned_2,to_cell) \
 	_(signed_1,s8,from_signed_1,to_fixnum) \
 	_(unsigned_1,u8,from_unsigned_1,to_cell) \
-	_(float,float,from_float,to_float) \
+	_(float,float,allot_float,to_float) \
-	_(double,double,from_double,to_double) \
+	_(double,double,allot_float,to_double) \
 	_(cell,void *,allot_alien,pinned_alien_offset)
 
 #define DECLARE_PRIMITIVE(name) VM_C_API void primitive_##name(factor_vm *parent);