FFI rewrite part 4: parameter and return value unboxing redesign

basis/classes/struct/struct.factor

@@ -166,16 +166,10 @@ 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 )
 

basis/compiler/alien/alien.factor

@@ -9,7 +9,5 @@ IN: compiler.alien
 
 : alien-parameters ( params -- seq )
     dup parameters>>
-    swap return>> large-struct? [ struct-return-pointer-type prefix ] when ;
+    swap return>> large-struct?
-
+    [ struct-return-on-stack? (stack-value) void* ? prefix ] when ;
-: alien-return ( params -- type )
-    return>> dup large-struct? [ drop void ] when ;

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

@@ -1,121 +1,89 @@
 ! 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 fry make sequences locals alien alien.private
 alien.strings alien.c-types alien.libraries classes.struct
 namespaces kernel strings libc quotations cpu.architecture
 compiler.alien 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
+        [| rep i |
+            src i cells rep f ^^load-memory-imm
+            rep struct-on-stack? 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) ( vregs -- )
+    ! Place instructions in reverse order, so that the
+    ! ##store-stack-param instructions come first. This is
+    ! because they are not clobber-insns and so we avoid some
+    ! spills that way.
+    [
+        first3 [ dup reg-class-of reg-class-full? ] dip or
+        [ [ alloc-stack-param ] keep \ ##store-stack-param new-insn ]
+        [ [ next-reg-param ] keep \ ##store-reg-param new-insn ]
+        if
+    ] map reverse % ;
 
 : objects>registers ( params -- )
     #! Generate code for unboxing a list of C types, then
     #! generate code for moving these parameters to registers on
     #! architectures where parameters are passed in registers.
-    [
+    [ abi>> ] [ parameters>> ] [ return>> ] tri
-        [ prepare-box-struct ] keep
+    '[ 
-        [ unbox-parameters ] keep
+        _ unbox-parameters
-        \ ##load-param-reg move-parameters
+        _ prepare-struct-area
+        (objects>registers)
     ] with-param-regs ;
 
 GENERIC: box-return ( c-type -- dst )
@@ -126,6 +94,9 @@ M: c-type box-return
 M: long-long-type box-return
     [ f ] dip boxer>> ^^box-long-long ;
 
+: if-small-struct ( c-type true false -- ? )
+    [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
+
 M: struct-c-type box-return
     [ ^^box-small-struct ] [ ^^box-large-struct ] if-small-struct ;
 
@@ -189,13 +160,12 @@ M: array dlsym-valid? '[ _ dlsym ] any? ;
 
 M: #alien-invoke emit-node
     [
-        ! Unbox parameters
+        {
-        dup objects>registers
+            [ objects>registers ]
-        ! Call function
+            [ alien-invoke-dlsym ##alien-invoke ]
-        dup alien-invoke-dlsym ##alien-invoke
+            [ stack-cleanup ##cleanup ]
-        ! Box return value
+            [ box-return* ]
-        dup ##cleanup
+        } cleave
-        box-return*
     ] emit-alien-node ;
 
 M: #alien-indirect emit-node
@@ -204,7 +174,7 @@ M: #alien-indirect emit-node
         {
             [ drop objects>registers ]
             [ nip ##alien-indirect ]
-            [ drop ##cleanup ]
+            [ drop stack-cleanup ##cleanup ]
             [ drop box-return* ]
         } 2cleave
     ] emit-alien-node ;
@@ -225,9 +195,18 @@ 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 ;
+
 : box-parameters ( params -- )
     alien-parameters
     [ length ##inc-d ]
@@ -239,10 +218,21 @@ 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 ;
+
+: (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,14 +257,13 @@ 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 ;
 
 M: #alien-callback emit-node
     dup params>> xt>> dup
@@ -284,11 +273,15 @@ M: #alien-callback emit-node
             [ registers>objects ]
             [ wrap-callback-quot ##alien-callback ]
             [
-                alien-return [ ##end-callback ] [
+                return>> {
-                    [ D 0 ^^peek ] dip
+                    { [ dup void eq? ] [ drop ##end-callback ] }
-                    ##end-callback
+                    { [ dup large-struct? ] [ drop ##end-callback ] }
-                    base-type unbox-return
+                    [
-                ] if-void
+                        [ D 0 ^^peek ] dip
+                        ##end-callback
+                        base-type unbox-return
+                    ]
+                } cond
             ] tri
         ] emit-alien-node
         ##epilogue

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/instructions/instructions.factor

@@ -612,6 +612,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 +655,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 +821,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/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, structs are never passed in param regs
+HOOK: struct-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 -- )
 

basis/cpu/ppc/ppc.factor

@@ -769,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

@@ -95,17 +95,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 ;
@@ -133,6 +130,26 @@ 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 rep reg-class-of return-reg rep %copy ;
+
+M:: x86.32 %store-long-long-return ( src1 src2 n func -- )
+    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 +159,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 +187,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 +198,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 +207,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
@@ -280,7 +252,7 @@ M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
 : funny-large-struct-return? ( params -- ? )
     #! MINGW ABI incompatibility disaster
     [ return>> large-struct? ]
-    [ abi>> mingw = os windows? not or ]
+    [ abi>> mingw eq? os windows? not or ]
     bi and ;
 
 : stack-arg-size ( params -- n )
@@ -301,8 +273,8 @@ M: x86.32 stack-cleanup ( params -- n )
         [ drop 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 +287,10 @@ 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 structs-on-stack? t ;
-    os linux? void* (stack-value) ? ;
+
+M: x86.32 struct-return-on-stack? os linux? not ;
 
 check-sse

basis/cpu/x86/64/64.factor

@@ -99,6 +99,33 @@ 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
+
+: %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 %store-struct-return ( 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: stack-params copy-register*
     drop
     {
@@ -108,59 +135,9 @@ 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 ;
@@ -185,7 +162,7 @@ M:: x86.64 %box-small-struct ( dst c-type -- )
         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 +175,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 +217,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 struct-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/x86.factor

@@ -1443,10 +1443,31 @@ 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 ;
+
+M:: x86 %store-return ( src rep -- )
+    rep reg-class-of return-reg 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 ;
 

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)