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" }
{ $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
-{ $values { "name" "a C type" } { "quot" { $quotation "( c-ptr n -- obj )" } } }
-{ $description "Outputs a quotation which reads values of this C type from a C structure." }
+HELP: alien-value
+{ $values { "c-ptr" c-ptr } { "offset" integer } { "c-type" c-type-name } { "value" object } }
+{ $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
-{ $values { "name" "a C type" } { "quot" { $quotation "( obj c-ptr n -- )" } } }
-{ $description "Outputs a quotation which writes values of this C type to a C structure." }
-{ $errors "Throws an error if the type does not exist." } ;
+HELP: set-alien-value
+{ $values { "value" object } { "c-ptr" c-ptr } { "offset" integer } { "c-type" c-type-name } }
+{ $description "Stores 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: define-deref
{ $values { "c-type" "a C type" } }
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
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>> ;
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 )
- [
- \ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
- ] [ ] make ;
+: array-accessor ( n c-ptr c-type -- c-ptr offset c-type )
+ [ swapd heap-size * >fixnum ] keep ; inline
+
+: 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
long-long-type new ;
: define-deref ( c-type -- )
- [ name>> CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
- (( c-ptr -- value )) define-inline ;
+ [ name>> CHAR: * prefix "alien.c-types" create ]
+ [ '[ 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 -- )
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 -- )
<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
"callback-effect" word-prop ;
: global-quot ( type word -- quot )
- name>> current-library get '[ _ _ address-of 0 ]
- swap c-getter append ;
+ swap [ name>> current-library get ] dip
+ '[ _ _ address-of 0 _ alien-value ] ;
: define-global ( type word -- )
[ nip ] [ global-quot ] 2bi (( -- value )) define-declared ;
GENERIC: (reader-quot) ( slot -- quot )
M: struct-slot-spec (reader-quot)
- [ type>> c-getter ]
- [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+ [ offset>> ] [ type>> ] bi '[ >c-ptr _ _ alien-value ] ;
M: struct-bit-slot-spec (reader-quot)
[ [ offset>> ] [ bits>> ] bi bit-reader ]
GENERIC: (writer-quot) ( slot -- quot )
M: struct-slot-spec (writer-quot)
- [ type>> c-setter ]
- [ offset>> [ >c-ptr ] swap suffix ] bi prepend ;
+ [ offset>> ] [ type>> ] bi '[ >c-ptr _ _ set-alien-value ] ;
M: struct-bit-slot-spec (writer-quot)
- [ offset>> ] [ bits>> ] bi bit-writer
- [ >c-ptr ] prepose ;
+ [ offset>> ] [ bits>> ] bi bit-writer [ >c-ptr ] prepose ;
: (boxer-quot) ( class -- quot )
'[ _ memory>struct ] ;
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces accessors math math.order assocs kernel sequences
-combinators classes words system cpu.architecture layouts compiler.cfg
-compiler.cfg.rpo compiler.cfg.instructions
-compiler.cfg.registers compiler.cfg.stack-frame ;
+USING: namespaces accessors math math.order assocs kernel
+sequences combinators classes words system fry locals
+cpu.architecture layouts compiler.cfg compiler.cfg.rpo
+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?
+: frame-required ( -- ) frame-required? on ;
GENERIC: compute-stack-frame* ( insn -- )
-: frame-required ( -- ) frame-required? on ;
-
-: request-stack-frame ( stack-frame -- )
+M:: ##local-allot compute-stack-frame* ( insn -- )
frame-required
- stack-frame [ max-stack-frame ] change ;
-
-M: ##local-allot compute-stack-frame*
- local-allot get >>offset
- 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 ;
M: insn compute-stack-frame* drop ;
-: request-spill-area ( n -- )
- stack-frame new swap >>spill-area-size request-stack-frame ;
-
-: request-local-allot ( n -- )
- stack-frame new swap >>local-allot request-stack-frame ;
-
-: compute-stack-frame ( cfg -- )
- 0 local-allot set
- stack-frame new stack-frame set
- [ spill-area-size>> [ request-spill-area ] unless-zero ]
- [ [ 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 ;
+: finalize-stack-frame ( 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 ;
+
+: <stack-frame> ( cfg -- 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 -- stack-frame/f )
+ [ [ instructions>> [ compute-stack-frame* ] each ] each-basic-block ]
+ [ frame-required? get [ <stack-frame> ] [ drop f ] if ]
+ bi ;
: build-stack-frame ( cfg -- cfg )
- [
- [ compute-stack-frame ]
- [
- frame-required? get stack-frame get f ?
- >>stack-frame
- ] bi
- ] with-scope ;
+ 0 param-area-size set
+ 0 allot-area-size set
+ cell allot-area-align set
+ dup compute-stack-frame >>stack-frame ;
: 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
_ [ 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
[ ^^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 ;
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 } }
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
INSN: ##local-allot
def: dst/int-rep
-literal: size offset ;
+literal: size align offset ;
INSN: ##box
def: dst/tagged-rep
{ 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 ] }
] unary-op ;
: emit-local-allot ( node -- )
- dup node-input-infos first literal>> dup integer?
- [ nip ds-drop f ^^local-allot ^^box-alien ds-push ]
- [ drop emit-primitive ]
+ dup node-input-infos first2 [ literal>> ] bi@ 2dup [ integer? ] both?
+ [ ds-drop ds-drop f ^^local-allot ^^box-alien ds-push drop ]
+ [ 2drop emit-primitive ]
if ;
+
+: emit-cleanup-allot ( -- )
+ [ ##no-tco ] emit-trivial-block ;
-! 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 ;
[ 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
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 ;
[ 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 ;
{ 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{
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 + + ;
-
-: 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 ;
+ [ spill-area-base>> ] [ spill-area-size>> ] bi + ;
: 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
! 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-definition ] [ heap-size '[ _ ] ] bi
- ] [ drop f ] if
+ [ depends-on-c-type ] [ heap-size '[ _ ] ] bi
] 1 define-partial-eval
! Eliminates a few redundant checks here and there
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,
M:: x86 %load-stack-param ( dst n rep -- )
dst n next-stack@ rep %copy ;
-M: x86 %local-allot ( dst size offset -- )
- nip local-allot-offset special-offset stack@ LEA ;
+M:: x86 %local-allot ( dst size align offset -- )
+ dst offset local-allot-offset special-offset stack@ LEA ;
M: x86 %alien-indirect ( src -- )
?spill-slot CALL ;
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
[ ] [ 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 }
[ 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
-[ 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
+USE: alien
-! 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
+: callback-1 ( -- c )
+ c:int { c:int c:int c:int c:int c:int } cdecl [ + + + + ] alien-callback ;
-[ 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
+: indirect-1 ( x x x x x c -- y )
+ 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
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
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
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
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 ;