Stack allocation improvements

- New with-out-parameters combinator
- Inhibit tail call optimization in frames with local allocation, to ensure that passing a stack allocated value to the last word in the quotation works
- local allocations are now aligned properly
- spill slots are now aligned properly aligned in frames which have parameter and local allocation areas

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

@@ -1,13 +1,13 @@
 USING: alien alien.complex help.syntax help.markup libc kernel.private
 byte-arrays strings hashtables alien.syntax alien.strings sequences
 io.encodings.string debugger destructors vocabs.loader
-classes.struct ;
+classes.struct math kernel ;
 QUALIFIED: math
 QUALIFIED: sequences
 IN: alien.c-types
 
 HELP: heap-size
-{ $values { "name" "a C type name" } { "size" math:integer } }
+{ $values { "name" c-type-name } { "size" math:integer } }
 { $description "Outputs the number of bytes needed for a heap-allocated value of this C type." }
 { $examples
     { $example "USING: alien alien.c-types prettyprint ;\nint heap-size ." "4" }
@@ -19,24 +19,24 @@ HELP: <c-type>
 { $description "Creates a prototypical C type. User code should use higher-level facilities to define C types; see " { $link "c-data" } "." } ;
 
 HELP: no-c-type
-{ $values { "name" "a C type name" } }
+{ $values { "name" c-type-name } }
 { $description "Throws a " { $link no-c-type } " error." }
 { $error-description "Thrown by " { $link c-type } " if a given string does not name a C type. When thrown during compile time, indicates a typo in an " { $link alien-invoke } " or " { $link alien-callback } " form." } ;
 
 HELP: c-type
-{ $values { "name" "a C type" } { "c-type" c-type } }
+{ $values { "name" c-type-name } { "c-type" c-type } }
 { $description "Looks up a C type by name." }
 { $errors "Throws a " { $link no-c-type } " error if the type does not exist, or the word is not a C type." } ;
 
-HELP: c-getter
+HELP: alien-value
-{ $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } }
+{ $values { "c-ptr" c-ptr } { "offset" integer } { "c-type" c-type-name } { "value" object } }
-{ $description "Outputs a quotation which reads values of this C type from a C structure." }
+{ $description "Loads a value at a byte offset from a base C pointer." }
 { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
 
-HELP: c-setter
+HELP: set-alien-value
-{ $values { "name" "a C type" } { "quot" { $quotation "( obj c-ptr n -- )" } } }
+{ $values { "value" object } { "c-ptr" c-ptr } { "offset" integer } { "c-type" c-type-name } }
-{ $description "Outputs a quotation which writes values of this C type to a C structure." }
+{ $description "Stores a value at a byte offset from a base C pointer." }
-{ $errors "Throws an error if the type does not exist." } ;
+{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
 
 HELP: define-deref
 { $values { "c-type" "a C type" } }

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

@@ -6,7 +6,7 @@ words splitting cpu.architecture alien alien.accessors
 alien.strings quotations layouts system compiler.units io
 io.files io.encodings.binary io.streams.memory accessors
 combinators effects continuations fry classes vocabs
-vocabs.loader words.symbol ;
+vocabs.loader words.symbol macros ;
 QUALIFIED: math
 IN: alien.c-types
 
@@ -93,7 +93,7 @@ GENERIC: c-type-setter ( name -- quot )
 
 M: c-type c-type-setter setter>> ;
 
-GENERIC: c-type-align ( name -- n )
+GENERIC: c-type-align ( name -- n ) foldable
 
 M: abstract-c-type c-type-align align>> ;
 
@@ -115,18 +115,22 @@ M: abstract-c-type heap-size size>> ;
 
 MIXIN: value-type
 
-: c-getter ( name -- quot )
+MACRO: alien-value ( c-type -- quot: ( c-ptr offset -- value ) )
     [ c-type-getter ] [ c-type-boxer-quot ] bi append ;
 
-: c-setter ( name -- quot )
+MACRO: set-alien-value ( c-type -- quot: ( value c-ptr offset -- ) )
     [ c-type-unboxer-quot [ [ ] ] [ '[ _ 2dip ] ] if-empty ]
     [ c-type-setter ]
     bi append ;
 
-: array-accessor ( c-type quot -- def )
+: array-accessor ( n c-ptr c-type -- c-ptr offset c-type )
-    [
+    [ swapd heap-size * >fixnum ] keep ; inline
-        \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
+
-    ] [ ] make ;
+: alien-element ( n c-ptr c-type -- value )
+    array-accessor alien-value ; inline
+
+: set-alien-element ( value n c-ptr c-type -- )
+    array-accessor set-alien-value ; inline
 
 PROTOCOL: c-type-protocol 
     c-type-class
@@ -159,12 +163,13 @@ TUPLE: long-long-type < c-type ;
     long-long-type new ;
 
 : define-deref ( c-type -- )
-    [ name>> CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
+    [ name>> CHAR: * prefix "alien.c-types" create ]
-    (( c-ptr -- value )) define-inline ;
+    [ '[ 0 _ alien-value ] ]
+    bi (( c-ptr -- value )) define-inline ;
 
 : define-out ( c-type -- )
     [ name>> "alien.c-types" constructor-word ]
-    [ dup c-setter '[ _ heap-size (byte-array) [ 0 @ ] keep ] ] bi
+    [ dup '[ _ heap-size (byte-array) [ 0 _ set-alien-value ] keep ] ] bi
     (( value -- c-ptr )) define-inline ;
 
 : define-primitive-type ( c-type name -- )

basis/alien/data/data.factor

@@ -2,7 +2,7 @@
 USING: accessors alien alien.c-types alien.arrays alien.strings
 arrays byte-arrays cpu.architecture fry io io.encodings.binary
 io.files io.streams.memory kernel libc math sequences words
-macros ;
+macros combinators generalizations ;
 IN: alien.data
 
 GENERIC: require-c-array ( c-type -- )
@@ -80,12 +80,29 @@ ERROR: local-allocation-error ;
 
 <PRIVATE
 
-: (local-allot) ( size -- alien ) local-allocation-error ;
+: (local-allot) ( size align -- alien ) local-allocation-error ;
+
+: (cleanup-allot) ( -- )
+    ! Inhibit TCO in order for the last word in the quotation
+    ! to still be abl to access scope-allocated data.
+    ;
 
 MACRO: (local-allots) ( c-types -- quot )
-    [ dup c-type-boxer-quot '[ _ heap-size (local-allot) @ ] ] map [ ] join ;
+    [ '[ _ [ heap-size ] [ c-type-align ] bi (local-allot) ] ] map [ ] join ;
+
+MACRO: box-values ( c-types -- quot )
+    [ c-type-boxer-quot ] map '[ _ spread ] ;
+
+MACRO: out-parameters ( c-types -- quot )
+    [ length ] [ [ '[ 0 _ alien-value ] ] map ] bi
+    '[ _ nkeep _ spread ] ;
 
 PRIVATE>
 
 : with-scoped-allocation ( c-types quot -- )
-    [ (local-allots) ] dip call ; inline
+    [ [ (local-allots) ] [ box-values ] bi ] dip call
+    (cleanup-allot) ; inline
+
+: with-out-parameters ( c-types quot finish -- values )
+    [ [ drop (local-allots) ] [ swap out-parameters ] 2bi ] dip call
+    (cleanup-allot) ; inline

basis/alien/parser/parser.factor

@@ -168,8 +168,8 @@ PREDICATE: alien-callback-type-word < typedef-word
     "callback-effect" word-prop ;
 
 : global-quot ( type word -- quot )
-    name>> current-library get '[ _ _ address-of 0 ]
+    swap [ name>> current-library get ] dip
-    swap c-getter append ;
+    '[ _ _ address-of 0 _ alien-value ] ;
 
 : define-global ( type word -- )
     [ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;

basis/classes/struct/struct.factor

@@ -101,8 +101,7 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
 GENERIC: (reader-quot) ( slot -- quot )
 
 M: struct-slot-spec (reader-quot)
-    [ type>> c-getter ]
+    [ offset>> ] [ type>> ] bi '[ >c-ptr _ _ alien-value ] ;
-    [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
 
 M: struct-bit-slot-spec (reader-quot)
     [ [ offset>> ] [ bits>> ] bi bit-reader ]
@@ -113,12 +112,10 @@ M: struct-bit-slot-spec (reader-quot)
 GENERIC: (writer-quot) ( slot -- quot )
 
 M: struct-slot-spec (writer-quot)
-    [ type>> c-setter ]
+    [ offset>> ] [ type>> ] bi '[ >c-ptr _ _ set-alien-value ] ;
-    [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
 
 M: struct-bit-slot-spec (writer-quot)
-    [ offset>> ] [ bits>> ] bi bit-writer
+    [ offset>> ] [ bits>> ] bi bit-writer [ >c-ptr ] prepose ;
-    [ >c-ptr ] prepose ;
 
 : (boxer-quot) ( class -- quot )
     '[ _ memory>struct ] ;

basis/compiler/cfg/build-stack-frame/build-stack-frame.factor

@@ -1,33 +1,33 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces accessors math math.order assocs kernel sequences
+USING: namespaces accessors math math.order assocs kernel
-combinators classes words system cpu.architecture layouts compiler.cfg
+sequences combinators classes words system fry locals
-compiler.cfg.rpo compiler.cfg.instructions
+cpu.architecture layouts compiler.cfg compiler.cfg.rpo
-compiler.cfg.registers compiler.cfg.stack-frame ;
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.stack-frame ;
 IN: compiler.cfg.build-stack-frame
 
-SYMBOL: local-allot
+SYMBOLS: param-area-size allot-area-size allot-area-align
-
+frame-required? ;
-SYMBOL: frame-required?
-
-GENERIC: compute-stack-frame* ( insn -- )
 
 : frame-required ( -- ) frame-required? on ;
 
-: request-stack-frame ( stack-frame -- )
+GENERIC: compute-stack-frame* ( insn -- )
-    frame-required
-    stack-frame [ max-stack-frame ] change ;
 
-M: ##local-allot compute-stack-frame*
+M:: ##local-allot compute-stack-frame* ( insn -- )
-    local-allot get >>offset
+    frame-required
-    size>> local-allot +@ ;
+    insn size>> :> s
+    insn align>> :> a
+    allot-area-align [ a max ] change
+    allot-area-size [ a align [ insn offset<< ] [ s + ] bi ] change ;
 
 M: ##stack-frame compute-stack-frame*
-    stack-frame>> request-stack-frame ;
+    frame-required
+    stack-frame>> param-area-size [ max ] change ;
 
 : vm-frame-required ( -- )
     frame-required
-    stack-frame new vm-stack-space >>params request-stack-frame ;
+    vm-stack-space param-area-size [ max ] change ;
 
 M: ##call-gc compute-stack-frame* drop vm-frame-required ;
 M: ##box compute-stack-frame* drop vm-frame-required ;
@@ -51,25 +51,27 @@ M: ##integer>float compute-stack-frame*
 
 M: insn compute-stack-frame* drop ;
 
-: request-spill-area ( n -- )
+: finalize-stack-frame ( stack-frame -- )
-    stack-frame new swap >>spill-area-size request-stack-frame ;
+    dup [ params>> ] [ allot-area-align>> ] bi align >>allot-area-base
+    dup [ [ allot-area-base>> ] [ allot-area-size>> ] bi + ] [ spill-area-align>> ] bi align >>spill-area-base
+    dup stack-frame-size >>total-size drop ;
 
-: request-local-allot ( n -- )
+: <stack-frame> ( cfg -- stack-frame )
-    stack-frame new swap >>local-allot request-stack-frame ;
+    [ stack-frame new ] dip
+    [ spill-area-size>> >>spill-area-size ]
+    [ spill-area-align>> >>spill-area-align ] bi
+    allot-area-size get >>allot-area-size
+    allot-area-align get >>allot-area-align
+    param-area-size get >>params
+    dup finalize-stack-frame ;
 
-: compute-stack-frame ( cfg -- )
+: compute-stack-frame ( cfg -- stack-frame/f )
-    0 local-allot set
+    [ [ instructions>> [ compute-stack-frame* ] each ] each-basic-block ]
-    stack-frame new stack-frame set
+    [ frame-required? get [ <stack-frame> ] [ drop f ] if ]
-    [ spill-area-size>> [ request-spill-area ] unless-zero ]
+    bi ;
-    [ [ instructions>> [ compute-stack-frame* ] each ] each-basic-block ] bi
-    local-allot get [ request-local-allot ] unless-zero
-    stack-frame get dup stack-frame-size >>total-size drop ;
 
 : build-stack-frame ( cfg -- cfg )
-    [
+    0 param-area-size set
-        [ compute-stack-frame ]
+    0 allot-area-size set
-        [
+    cell allot-area-align set
-            frame-required? get stack-frame get f ?
+    dup compute-stack-frame >>stack-frame ;
-            >>stack-frame
-        ] bi
-    ] with-scope ;

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

@@ -23,7 +23,7 @@ IN: compiler.cfg.builder.alien
 
 : prepare-struct-caller ( vregs reps return -- vregs' reps' return-vreg/f )
     dup large-struct? [
-        heap-size f ^^local-allot [
+        heap-size cell f ^^local-allot [
             '[ _ prefix ]
             [ int-rep struct-return-on-stack? 2array prefix ] bi*
         ] keep
@@ -93,12 +93,9 @@ M: array dlsym-valid? '[ _ dlsym ] any? ;
         _ [ alien-node-height ] bi
     ] emit-trivial-block ; inline
 
-: <alien-stack-frame> ( stack-size -- stack-frame )
-    stack-frame new swap >>params ;
-
 : emit-stack-frame ( stack-size params -- )
     [ [ return>> ] [ abi>> ] bi stack-cleanup ##cleanup ]
-    [ drop <alien-stack-frame> ##stack-frame ]
+    [ drop ##stack-frame ]
     2bi ;
 
 M: #alien-invoke emit-node

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

@@ -49,7 +49,7 @@ M: c-type unbox
     [ ^^unbox 1array ] [ nip f 2array 1array ] 2bi ;
 
 M: long-long-type unbox
-    [ 8 f ^^local-allot ] dip '[ _ unboxer>> ##unbox-long-long ] keep
+    [ 8 cell f ^^local-allot ] dip '[ _ unboxer>> ##unbox-long-long ] keep
     0 cell [ int-rep f ^^load-memory-imm ] bi-curry@ bi 2array
     int-rep long-long-on-stack? 2array dup 2array ;
 
@@ -67,7 +67,7 @@ M: long-long-type unbox-parameter unbox ;
 
 M: struct-c-type unbox-parameter
     dup value-struct? [ unbox ] [
-        [ nip heap-size f ^^local-allot dup ]
+        [ nip heap-size cell f ^^local-allot dup ]
         [ [ ^^unbox-any-c-ptr ] dip explode-struct keys ] 2bi
         implode-struct
         1array { { int-rep f } }

basis/compiler/cfg/cfg.factor

@@ -22,7 +22,7 @@ number
 M: basic-block hashcode* nip id>> ;
 
 TUPLE: cfg { entry basic-block } word label
-spill-area-size
+spill-area-size spill-area-align
 stack-frame
 frame-pointer?
 post-order linear-order

basis/compiler/cfg/instructions/instructions.factor

@@ -660,7 +660,7 @@ literal: n rep ;
 
 INSN: ##local-allot
 def: dst/int-rep
-literal: size offset ;
+literal: size align offset ;
 
 INSN: ##box
 def: dst/tagged-rep

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -66,6 +66,7 @@ IN: compiler.cfg.intrinsics
     { byte-arrays:(byte-array) [ emit-(byte-array) ] }
     { kernel:<wrapper> [ emit-simple-allot ] }
     { alien.data.private:(local-allot) [ emit-local-allot ] }
+    { alien.data.private:(cleanup-allot) [ drop emit-cleanup-allot ] }
     { alien:<displaced-alien> [ emit-<displaced-alien> ] }
     { alien.accessors:alien-unsigned-1 [ int-rep alien.c-types:uchar emit-load-memory ] }
     { alien.accessors:set-alien-unsigned-1 [ int-rep alien.c-types:uchar emit-store-memory ] }

basis/compiler/cfg/intrinsics/misc/misc.factor

@@ -54,7 +54,10 @@ IN: compiler.cfg.intrinsics.misc
     ] unary-op ;
 
 : emit-local-allot ( node -- )
-    dup node-input-infos first literal>> dup integer?
+    dup node-input-infos first2 [ literal>> ] bi@ 2dup [ integer? ] both?
-    [ nip ds-drop f ^^local-allot ^^box-alien ds-push ]
+    [ ds-drop ds-drop f ^^local-allot ^^box-alien ds-push drop ]
-    [ drop emit-primitive ]
+    [ 2drop emit-primitive ]
     if ;
+
+: emit-cleanup-allot ( -- )
+    [ ##no-tco ] emit-trivial-block ;

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

@@ -1,7 +1,7 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays accessors assocs combinators cpu.architecture fry
-heaps kernel math math.order namespaces sequences vectors
+heaps kernel math math.order namespaces layouts sequences vectors
 linked-assocs compiler.cfg compiler.cfg.registers
 compiler.cfg.instructions
 compiler.cfg.linear-scan.live-intervals ;
@@ -122,6 +122,9 @@ SYMBOL: unhandled-intervals
     [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop
     <spill-slot> ;
 
+: align-spill-area ( align -- )
+    cfg get [ max ] change-spill-area-align drop ;
+
 ! Minheap of sync points which still need to be processed
 SYMBOL: unhandled-sync-points
 
@@ -129,7 +132,10 @@ SYMBOL: unhandled-sync-points
 SYMBOL: spill-slots
 
 : assign-spill-slot ( coalesced-vreg rep -- spill-slot )
-    rep-size spill-slots get [ nip next-spill-slot ] 2cache ;
+    rep-size
+    [ align-spill-area ]
+    [ spill-slots get [ nip next-spill-slot ] 2cache ]
+    bi ;
 
 : lookup-spill-slot ( coalesced-vreg rep -- spill-slot )
     rep-size 2array spill-slots get ?at [ ] [ bad-vreg ] if ;
@@ -141,7 +147,7 @@ SYMBOL: spill-slots
     [ V{ } clone ] reg-class-assoc active-intervals set
     [ V{ } clone ] reg-class-assoc inactive-intervals set
     V{ } clone handled-intervals set
-    cfg get 0 >>spill-area-size drop
+    cfg get 0 >>spill-area-size cell >>spill-area-align drop
     H{ } clone spill-slots set
     -1 progress set ;
 

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

@@ -76,7 +76,7 @@ check-numbering? on
     { T{ live-range f 0 5 } } 0 split-ranges
 ] unit-test
 
-cfg new 0 >>spill-area-size cfg set
+cfg new 0 >>spill-area-size 4 >>spill-area-align cfg set
 H{ } spill-slots set
 
 H{

basis/compiler/cfg/stack-frame/stack-frame.factor

@@ -7,24 +7,20 @@ IN: compiler.cfg.stack-frame
 
 TUPLE: stack-frame
 { params integer }
-{ local-allot integer }
+{ allot-area-size integer }
+{ allot-area-align integer }
 { spill-area-size integer }
-{ total-size integer } ;
+{ spill-area-align integer }
+
+{ total-size integer }
+{ allot-area-base integer }
+{ spill-area-base integer } ;
 
-! Stack frame utilities
 : local-allot-offset ( n -- offset )
-    stack-frame get params>> + ;
+    stack-frame get allot-area-base>> + ;
 
 : spill-offset ( n -- offset )
-    stack-frame get [ params>> ] [ local-allot>> ] bi + + ;
+    stack-frame get spill-area-base>> + ;
 
 : (stack-frame-size) ( stack-frame -- n )
-    [ params>> ] [ local-allot>> ] [ spill-area-size>> ] tri + + ;
+    [ spill-area-base>> ] [ spill-area-size>> ] bi + ;
-
-: max-stack-frame ( frame1 frame2 -- frame3 )
-    [ stack-frame new ] 2dip
-    {
-        [ [ params>> ] bi@ max >>params ]
-        [ [ local-allot>> ] bi@ max >>local-allot ]
-        [ [ spill-area-size>> ] bi@ max >>spill-area-size ]
-    } 2cleave ;

basis/compiler/tests/alien.factor

@@ -767,3 +767,20 @@ mingw? [
 : blah ( -- x ) { RECT } [ 1.5 >>x 2.0 >>y [ x>> ] [ y>> ] bi * >fixnum ] with-scoped-allocation ;
 
 [ 3 ] [ blah ] unit-test
+
+: out-param-test ( -- b )
+    { int } [ [ 12 ] dip 0 int set-alien-value ] [ ] with-out-parameters ;
+
+[ 12 ] [ out-param-test ] unit-test
+
+: out-param-callback ( -- a )
+    void { int pointer: int } cdecl
+    [ [ 2 * ] dip 0 int set-alien-value ] alien-callback ;
+
+: out-param-indirect ( a a -- b )
+    { int } [
+        swap void { int pointer: int } cdecl
+        alien-indirect
+    ] [ ] with-out-parameters ;
+
+[ 12 ] [ 6 out-param-callback out-param-indirect ] unit-test

basis/compiler/tree/propagation/transforms/transforms.factor

@@ -310,9 +310,7 @@ M\ set intersect [ intersect-quot ] 1 define-partial-eval
 ! We want to constant-fold calls to heap-size, and recompile those
 ! calls when a C type is redefined
 \ heap-size [
-    dup word? [
+    [ depends-on-c-type ] [ heap-size '[ _ ] ] bi
-        [ depends-on-definition ] [ heap-size '[ _ ] ] bi
-    ] [ drop f ] if
 ] 1 define-partial-eval
 
 ! Eliminates a few redundant checks here and there

basis/cpu/architecture/architecture.factor

@@ -586,7 +586,7 @@ HOOK: %store-reg-param cpu ( src reg rep -- )
 
 HOOK: %store-stack-param cpu ( src n rep -- )
 
-HOOK: %local-allot cpu ( dst size offset -- )
+HOOK: %local-allot cpu ( dst size align offset -- )
 
 ! Call a function to convert a value into a tagged pointer,
 ! possibly allocating a bignum, float, or alien instance,

basis/cpu/x86/x86.factor

@@ -588,8 +588,8 @@ M:: x86 %store-stack-param ( src n rep -- )
 M:: x86 %load-stack-param ( dst n rep -- )
     dst n next-stack@ rep %copy ;
 
-M: x86 %local-allot ( dst size offset -- )
+M:: x86 %local-allot ( dst size align offset -- )
-    nip local-allot-offset special-offset stack@ LEA ;
+    dst offset local-allot-offset special-offset stack@ LEA ;
 
 M: x86 %alien-indirect ( src -- )
     ?spill-slot CALL ;

basis/math/vectors/simd/simd-tests.factor

@@ -6,7 +6,7 @@ tools.test vocabs assocs compiler.cfg.debugger words
 locals combinators cpu.architecture namespaces byte-arrays alien
 specialized-arrays classes.struct eval classes.algebra sets
 quotations math.constants compiler.units splitting math.matrices
-math.vectors.simd.cords ;
+math.vectors.simd.cords alien.data ;
 FROM: math.vectors.simd.intrinsics => alien-vector set-alien-vector ;
 QUALIFIED-WITH: alien.c-types c
 SPECIALIZED-ARRAY: c:float
@@ -610,6 +610,17 @@ STRUCT: simd-struct
 
 [ ] [ char-16 new 1array stack. ] unit-test
 
+! Test some sequence protocol stuff
+[ t ] [ 4 double-4{ 1 2 3 4 } new-sequence double-4? ] unit-test
+[ double-4{ 2 3 4 5 } ] [ double-4{ 1 2 3 4 } [ 1 + ] map ] unit-test
+
+! Test cross product
+[ float-4{ 0.0 0.0 1.0 0.0 } ] [ float-4{ 1.0 0.0 0.0 0.0 } float-4{ 0.0 1.0 0.0 0.0 } cross ] unit-test
+[ float-4{ 0.0 -1.0 0.0 0.0 } ] [ float-4{ 1.0 0.0 0.0 0.0 } float-4{ 0.0 0.0 1.0 0.0 } cross ] unit-test
+
+[ double-4{ 0.0 0.0 1.0 0.0 } ] [ double-4{ 1.0 0.0 0.0 0.0 } double-4{ 0.0 1.0 0.0 0.0 } cross ] unit-test
+[ double-4{ 0.0 -1.0 0.0 0.0 } ] [ double-4{ 1.0 0.0 0.0 0.0 } double-4{ 0.0 0.0 1.0 0.0 } cross ] unit-test
+
 ! CSSA bug
 [ 4000000 ] [
     int-4{ 1000 1000 1000 1000 }
@@ -650,13 +661,46 @@ STRUCT: simd-struct
 [ float-4{ 0 0 0 0 } ]
 [ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-2 ] unit-test
 
-! Test some sequence protocol stuff
+USE: alien
-[ t ] [ 4 double-4{ 1 2 3 4 } new-sequence double-4? ] unit-test
-[ double-4{ 2 3 4 5 } ] [ double-4{ 1 2 3 4 } [ 1 + ] map ] unit-test
 
-! Test cross product
+: callback-1 ( -- c )
-[ float-4{ 0.0 0.0 1.0 0.0 } ] [ float-4{ 1.0 0.0 0.0 0.0 } float-4{ 0.0 1.0 0.0 0.0 } cross ] unit-test
+    c:int { c:int c:int c:int c:int c:int } cdecl [ + + + + ] alien-callback ;
-[ float-4{ 0.0 -1.0 0.0 0.0 } ] [ float-4{ 1.0 0.0 0.0 0.0 } float-4{ 0.0 0.0 1.0 0.0 } cross ] unit-test
 
-[ double-4{ 0.0 0.0 1.0 0.0 } ] [ double-4{ 1.0 0.0 0.0 0.0 } double-4{ 0.0 1.0 0.0 0.0 } cross ] unit-test
+: indirect-1 ( x x x x x c -- y )
-[ double-4{ 0.0 -1.0 0.0 0.0 } ] [ double-4{ 1.0 0.0 0.0 0.0 } double-4{ 0.0 0.0 1.0 0.0 } cross ] unit-test
+    c:int { c:int c:int c:int c:int c:int } cdecl alien-indirect ; inline
+
+: simd-spill-test-3 ( a b d c -- v )
+    { float float-4 float-4 float } declare
+    [ [ 3.0 + ] 2dip v+ ] dip sin v*n n*v
+    10 5 100 50 500 callback-1 indirect-1 665 assert= ;
+
+[ float-4{ 0 0 0 0 } ]
+[ 5.0 float-4{ 1 2 3 4 } float-4{ 4 5 6 7 } 0.0 simd-spill-test-3 ] unit-test
+
+! Stack allocation of SIMD values -- make sure that everything is
+! aligned right
+
+: simd-stack-test ( -- b c )
+    { c:int float-4 } [
+        [ 123 swap 0 c:int c:set-alien-value ]
+        [ float-4{ 1 2 3 4 } swap 0 float-4 c:set-alien-value ] bi*
+    ] [ ] with-out-parameters ;
+
+[ 123 float-4{ 1 2 3 4 } ] [ simd-stack-test ] unit-test
+
+! Stack allocation + spilling
+
+: (simd-stack-spill-test) ( -- n ) 17 ;
+
+: simd-stack-spill-test ( x -- b c )
+    { c:int } [
+        123 swap 0 c:int c:set-alien-value
+        >float (simd-stack-spill-test) float-4-with swap cos v*n
+    ] [ ] with-out-parameters ;
+
+[ ] [
+    1.047197551196598 simd-stack-spill-test
+    [ float-4{ 8.5 8.5 8.5 8.5 } approx= t assert= ]
+    [ 123 assert= ]
+    bi*
+] unit-test

basis/math/vectors/simd/simd.factor

@@ -254,8 +254,6 @@ ELT     [ A-rep rep-component-type ]
 N       [ A-rep rep-length ]
 COERCER [ ELT c:c-type-class "coercer" word-prop [ ] or ]
 
-SET-NTH [ ELT dup c:c-setter c:array-accessor ]
-
 BOA-EFFECT [ N "n" <array> { "v" } <effect> ]
 
 WHERE
@@ -271,7 +269,7 @@ M: A nth-unsafe
     swap \ A-rep [ (simd-select) ] [ call-next-method ] vn->n-op ; inline
 M: A set-nth-unsafe
     [ ELT boolean>element ] 2dip
-    underlying>> SET-NTH call ; inline
+    underlying>> ELT c:set-alien-element ; inline
 
 : >A ( seq -- simd ) \ A new clone-like ; inline
 

basis/specialized-arrays/specialized-arrays.factor

@@ -41,13 +41,9 @@ A          DEFINES-CLASS ${T}-array
 malloc-A   DEFINES malloc-${A}
 >A         DEFINES >${A}
 A-cast     DEFINES ${A}-cast
-           
 A{         DEFINES ${A}{
 A@         DEFINES ${A}@
 
-NTH        [ T dup c-getter array-accessor ]
-SET-NTH    [ T dup c-setter array-accessor ]
-
 WHERE
 
 TUPLE: A
@@ -73,9 +69,9 @@ M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline
 
 M: A length length>> ; inline
 
-M: A nth-unsafe underlying>> NTH call ; inline
+M: A nth-unsafe underlying>> \ T alien-element ; inline
 
-M: A set-nth-unsafe underlying>> SET-NTH call ; inline
+M: A set-nth-unsafe underlying>> \ T set-alien-element ; inline
 
 : >A ( seq -- specialized-array ) A new clone-like ;