$nl\r
"C type specifiers for array types are documented in " { $link "c-types-specs" } "."\r
$nl\r
-"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets. They can also be loaded and constructed through their primitive C types:"\r
-{ $subsection require-c-arrays }\r
+"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " vocabulary set. They can also be loaded and constructed through their primitive C types:"\r
+{ $subsection require-c-array }\r
{ $subsection <c-array> }\r
{ $subsection <c-direct-array> } ;\r
M: array c-type-boxer-quot
unclip
[ array-length ]
- [ [ require-c-arrays ] keep ] bi*
+ [ [ require-c-array ] keep ] bi*
[ <c-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
HELP: <c-array>
{ $values { "len" "a non-negative integer" } { "c-type" "a C type" } { "array" byte-array } }
{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
-{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
HELP: <c-object>
HELP: malloc-array
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
-{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
}
} ;
-HELP: require-c-arrays
+HELP: require-c-array
{ $values { "c-type" "a C type" } }
-{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array or direct array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-direct-array> } " vocabularies." }
-{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets for details on the underlying sequence types loaded." } ;
+{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-direct-array> } " vocabularies." }
+{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence types loaded." } ;
HELP: <c-direct-array>
{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
-{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ;
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } ;
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
array-class
array-constructor
(array)-constructor
-direct-array-class
-direct-array-constructor
-sequence-mixin-class ;
+direct-array-constructor ;
TUPLE: c-type < abstract-c-type
boxer
M: abstract-c-type heap-size size>> ;
-GENERIC: require-c-arrays ( c-type -- )
+GENERIC: require-c-array ( c-type -- )
-M: object require-c-arrays
+M: object require-c-array
drop ;
-M: c-type require-c-arrays
- [ array-class>> ?require-word ]
- [ sequence-mixin-class>> ?require-word ]
- [ direct-array-class>> ?require-word ] tri ;
+M: c-type require-c-array
+ array-class>> ?require-word ;
-M: string require-c-arrays
- c-type require-c-arrays ;
+M: string require-c-array
+ c-type require-c-array ;
-M: array require-c-arrays
- first c-type require-c-arrays ;
+M: array require-c-array
+ first c-type require-c-array ;
ERROR: specialized-array-vocab-not-loaded vocab word ;
]
[
[ "specialized-arrays." prepend ]
- [ "-sequence" append ] bi* ?lookup >>sequence-mixin-class
- ]
- [
- [ "specialized-arrays.direct." prepend ]
- [ "direct-" "-array" surround ] bi* ?lookup >>direct-array-class
- ]
- [
- [ "specialized-arrays.direct." prepend ]
[ "<direct-" "-array>" surround ] bi* ?lookup >>direct-array-constructor
]
} 2cleave ;
4 >>align
"box_float" >>boxer
"to_float" >>unboxer
- single-float-rep >>rep
+ float-rep >>rep
[ >float ] >>unboxer-quot
"float" set-array-class
"float" define-primitive-type
8 >>align
"box_double" >>boxer
"to_double" >>unboxer
- double-float-rep >>rep
+ double-rep >>rep
[ >float ] >>unboxer-quot
"double" set-array-class
"double" define-primitive-type
] bi append ;
M: struct make-mirror <struct-mirror> ;
+
+INSTANCE: struct-mirror assoc
io.encodings.utf8 io.pathnames io.streams.string kernel libc
literals math mirrors multiline namespaces prettyprint
prettyprint.config see sequences specialized-arrays.char
-specialized-arrays.direct.int specialized-arrays.ushort
+specialized-arrays.int specialized-arrays.ushort
struct-arrays system tools.test ;
IN: classes.struct.tests
[ f ] [ [ memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
+[ t ] [
+ [ struct-test-optimization <struct> struct-test-optimization <struct> [ x>> ] bi@ ]
+ { x>> } inlined?
+] unit-test
+
! Test cloning structs
STRUCT: clone-test-struct { x int } { y char[3] } ;
: struct-that's-a-word ( -- ) "OOPS" throw ;
[ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
+
alien.structs.fields arrays byte-arrays classes classes.parser
classes.tuple classes.tuple.parser classes.tuple.private
combinators combinators.short-circuit combinators.smart
-functors.backend fry generalizations generic.parser kernel
-kernel.private lexer libc locals macros make math math.order parser
-quotations sequences slots slots.private struct-arrays vectors
-words compiler.tree.propagation.transforms specialized-arrays.direct.uchar ;
+definitions functors.backend fry generalizations generic.parser
+kernel kernel.private lexer libc locals macros make math math.order
+parser quotations sequences slots slots.private struct-arrays vectors
+words compiler.tree.propagation.transforms specialized-arrays.uchar ;
FROM: slots => reader-word writer-word ;
IN: classes.struct
TUPLE: struct-slot-spec < slot-spec
c-type ;
-PREDICATE: struct-class < tuple-class
- { [ \ struct subclass-of? ] [ all-slots length 1 = ] } 1&& ;
+PREDICATE: struct-class < tuple-class \ struct subclass-of? ;
: struct-slots ( struct-class -- slots )
"struct-slots" word-prop ;
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
: memory>struct ( ptr class -- struct )
- [ 1array ] dip slots>tuple ;
-
-\ memory>struct [
- dup struct-class? [ '[ _ boa ] ] [ drop f ] if
-] 1 define-partial-eval
+ ! This is sub-optimal if the class is not literal, but gets
+ ! optimized down to efficient code if it is.
+ '[ _ boa ] call( ptr -- struct ) ; inline
<PRIVATE
: (init-struct) ( class with-prototype: ( prototype -- alien ) sans-prototype: ( class -- alien ) -- alien )
[ \ struct-slot-values ] [ struct-slot-values-quot ] bi
define-inline-method ;
-: (define-byte-length-method) ( class -- )
- [ \ byte-length ] [ heap-size \ drop swap [ ] 2sequence ] bi
- define-inline-method ;
-
: clone-underlying ( struct -- byte-array )
[ >c-ptr ] [ byte-length ] bi memory>byte-array ; inline
M: struct-class heap-size
"struct-size" word-prop ;
+M: struct byte-length
+ class "struct-size" word-prop ; foldable
+
! class definition
<PRIVATE
: (struct-methods) ( class -- )
[ (define-struct-slot-values-method) ]
- [ (define-byte-length-method) ]
[ (define-clone-method) ]
- tri ;
+ bi ;
: (struct-word-props) ( class slots size align -- )
[
: check-struct-slots ( slots -- )
[ c-type>> c-type drop ] each ;
+: redefine-struct-tuple-class ( class -- )
+ [ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
+
: (define-struct-class) ( class slots offsets-quot -- )
[
[ struct-must-have-slots ]
- [ drop struct f define-tuple-class ] if-empty
+ [ drop redefine-struct-tuple-class ] if-empty
]
swap '[
make-slots dup
locals math sequences vectors fry libc destructors ;
IN: cocoa.enumeration
-<< "id" require-c-arrays >>
+<< "id" require-c-array >>
CONSTANT: NS-EACH-BUFFER-SIZE 16
stack-checker kernel math namespaces make quotations sequences
strings words cocoa.runtime io macros memoize io.encodings.utf8
effects libc libc.private lexer init core-foundation fry
-generalizations specialized-arrays.direct.alien ;
+generalizations specialized-arrays.alien ;
IN: cocoa.messages
: make-sender ( method function -- quot )
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces assocs hashtables sequences arrays
-accessors vectors combinators sets classes cpu.architecture compiler.cfg
-compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.copy-prop compiler.cfg.rpo compiler.cfg.liveness ;
+accessors vectors combinators sets classes cpu.architecture
+compiler.cfg compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.def-use compiler.cfg.copy-prop compiler.cfg.rpo
+compiler.cfg.liveness ;
IN: compiler.cfg.alias-analysis
! We try to eliminate redundant slot operations using some simple heuristics.
GENERIC: analyze-aliases* ( insn -- insn' )
+M: insn analyze-aliases*
+ dup defs-vreg [ set-heap-ac ] when* ;
+
M: ##load-immediate analyze-aliases*
dup [ val>> ] [ dst>> ] bi constants get set-at ;
-M: ##flushable analyze-aliases*
- dup dst>> set-heap-ac ;
-
M: ##allocation analyze-aliases*
#! A freshly allocated object is distinct from any other
#! object.
#! vreg, since they both contain the same value.
dup record-copy ;
-M: insn analyze-aliases* ;
-
: analyze-aliases ( insns -- insns' )
[ insn# set analyze-aliases* ] map-index sift ;
[ f t ] [
[ { fixnum simple-alien } declare <displaced-alien> 0 alien-cell ]
[ [ ##unbox-any-c-ptr? ] contains-insn? ]
- [ [ ##slot-imm? ] contains-insn? ] bi
+ [ [ ##unbox-alien? ] contains-insn? ] bi
+] unit-test
+
+[ f t ] [
+ [ { byte-array fixnum } declare alien-cell 4 alien-float ]
+ [ [ ##box-alien? ] contains-insn? ]
+ [ [ ##box-float? ] contains-insn? ] bi
+] unit-test
+
+[ f t ] [
+ [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
+ [ [ ##box-alien? ] contains-insn? ]
+ [ [ ##box-float? ] contains-insn? ] bi
] unit-test
\ No newline at end of file
: emit-actual-if ( #if -- )
! Inputs to the final instruction need to be copied because of
! loc>vreg sync
- ds-pop ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
+ ds-pop any-rep ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
M: #if emit-node
{
dup instructions>> last {
[ ##branch? ]
[ ##dispatch? ]
- [ ##conditional-branch? ]
+ [ ##compare-branch? ]
[ ##compare-imm-branch? ]
+ [ ##compare-float-branch? ]
[ ##fixnum-add? ]
[ ##fixnum-sub? ]
[ ##fixnum-mul? ]
USING: assocs math.order sequences ;
IN: compiler.cfg.comparisons
-SYMBOLS: cc< cc<= cc= cc> cc>= cc/= ;
+SYMBOL: +unordered+
+
+SYMBOLS:
+ cc< cc<= cc= cc> cc>= cc<> cc<>=
+ cc/< cc/<= cc/= cc/> cc/>= cc/<> cc/<>= ;
: negate-cc ( cc -- cc' )
H{
- { cc< cc>= }
- { cc<= cc> }
- { cc> cc<= }
- { cc>= cc< }
- { cc= cc/= }
- { cc/= cc= }
+ { cc< cc/< }
+ { cc<= cc/<= }
+ { cc> cc/> }
+ { cc>= cc/>= }
+ { cc= cc/= }
+ { cc<> cc/<> }
+ { cc<>= cc/<>= }
+ { cc/< cc< }
+ { cc/<= cc<= }
+ { cc/> cc> }
+ { cc/>= cc>= }
+ { cc/= cc= }
+ { cc/<> cc<> }
+ { cc/<>= cc<>= }
} at ;
: swap-cc ( cc -- cc' )
H{
- { cc< cc> }
- { cc<= cc>= }
- { cc> cc< }
- { cc>= cc<= }
- { cc= cc= }
- { cc/= cc/= }
+ { cc< cc> }
+ { cc<= cc>= }
+ { cc> cc< }
+ { cc>= cc<= }
+ { cc= cc= }
+ { cc<> cc<> }
+ { cc<>= cc<>= }
+ { cc/< cc/> }
+ { cc/<= cc/>= }
+ { cc/> cc/< }
+ { cc/>= cc/<= }
+ { cc/= cc/= }
+ { cc/<> cc/<> }
+ { cc/<>= cc/<>= }
+ } at ;
+
+: order-cc ( cc -- cc' )
+ H{
+ { cc< cc< }
+ { cc<= cc<= }
+ { cc> cc> }
+ { cc>= cc>= }
+ { cc= cc= }
+ { cc<> cc/= }
+ { cc<>= t }
+ { cc/< cc>= }
+ { cc/<= cc> }
+ { cc/> cc<= }
+ { cc/>= cc< }
+ { cc/= cc/= }
+ { cc/<> cc= }
+ { cc/<>= f }
} at ;
: evaluate-cc ( result cc -- ? )
H{
- { cc< { +lt+ } }
- { cc<= { +lt+ +eq+ } }
- { cc= { +eq+ } }
- { cc>= { +eq+ +gt+ } }
- { cc> { +gt+ } }
- { cc/= { +lt+ +gt+ } }
- } at memq? ;
\ No newline at end of file
+ { cc< { +lt+ } }
+ { cc<= { +lt+ +eq+ } }
+ { cc= { +eq+ } }
+ { cc>= { +eq+ +gt+ } }
+ { cc> { +gt+ } }
+ { cc<> { +lt+ +gt+ } }
+ { cc<>= { +lt+ +eq+ +gt+ } }
+ { cc/< { +eq+ +gt+ +unordered+ } }
+ { cc/<= { +gt+ +unordered+ } }
+ { cc/= { +lt+ +gt+ +unordered+ } }
+ { cc/>= { +lt+ +unordered+ } }
+ { cc/> { +lt+ +eq+ +unordered+ } }
+ { cc/<> { +eq+ +unordered+ } }
+ { cc/<>= { +unordered+ } }
+ } at memq? ;
+
M: ##write-barrier build-liveness-graph
dup src>> setter-liveness-graph ;
-M: ##flushable build-liveness-graph
- dup dst>> add-edges ;
-
M: ##allot build-liveness-graph
- [ dst>> allocations get conjoin ]
- [ call-next-method ] bi ;
+ [ dst>> allocations get conjoin ] [ call-next-method ] bi ;
-M: insn build-liveness-graph drop ;
+M: insn build-liveness-graph
+ dup defs-vreg dup [ add-edges ] [ 2drop ] if ;
GENERIC: compute-live-vregs ( insn -- )
M: ##write-barrier compute-live-vregs
dup src>> setter-live-vregs ;
-M: ##flushable compute-live-vregs drop ;
+M: ##fixnum-add compute-live-vregs record-live ;
+
+M: ##fixnum-sub compute-live-vregs record-live ;
+
+M: ##fixnum-mul compute-live-vregs record-live ;
M: insn compute-live-vregs
- record-live ;
+ dup defs-vreg [ drop ] [ record-live ] if ;
GENERIC: live-insn? ( insn -- ? )
-M: ##flushable live-insn? dst>> live-vreg? ;
-
M: ##set-slot live-insn? obj>> live-vreg? ;
M: ##set-slot-imm live-insn? obj>> live-vreg? ;
M: ##write-barrier live-insn? src>> live-vreg? ;
-M: insn live-insn? drop t ;
+M: ##fixnum-add live-insn? drop t ;
+
+M: ##fixnum-sub live-insn? drop t ;
+
+M: ##fixnum-mul live-insn? drop t ;
+
+M: insn live-insn? defs-vreg [ live-vreg? ] [ t ] if* ;
: eliminate-dead-code ( cfg -- cfg' )
+ ! Even though we don't use predecessors directly, we depend
+ ! on the predecessors pass updating phi nodes to remove dead
+ ! inputs.
needs-predecessors
init-dead-code
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel assocs sequences namespaces fry
-sets compiler.cfg.rpo compiler.cfg.instructions locals ;
+USING: accessors assocs arrays classes combinators
+compiler.units fry generalizations generic kernel locals
+namespaces quotations sequences sets slots words
+compiler.cfg.instructions compiler.cfg.instructions.syntax
+compiler.cfg.rpo ;
IN: compiler.cfg.def-use
GENERIC: defs-vreg ( insn -- vreg/f )
GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
-M: ##flushable defs-vreg dst>> ;
-M: ##fixnum-overflow defs-vreg dst>> ;
-M: _fixnum-overflow defs-vreg dst>> ;
-M: insn defs-vreg drop f ;
-
-M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
-M: ##unary/temp temp-vregs temp>> 1array ;
-M: ##allot temp-vregs temp>> 1array ;
-M: ##dispatch temp-vregs temp>> 1array ;
-M: ##slot temp-vregs temp>> 1array ;
-M: ##set-slot temp-vregs temp>> 1array ;
-M: ##string-nth temp-vregs temp>> 1array ;
-M: ##set-string-nth-fast temp-vregs temp>> 1array ;
-M: ##box-displaced-alien temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
-M: ##compare temp-vregs temp>> 1array ;
-M: ##compare-imm temp-vregs temp>> 1array ;
-M: ##compare-float temp-vregs temp>> 1array ;
-M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
-M: _dispatch temp-vregs temp>> 1array ;
-M: insn temp-vregs drop f ;
-
-M: ##unary uses-vregs src>> 1array ;
-M: ##binary uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
-M: ##binary-imm uses-vregs src1>> 1array ;
-M: ##effect uses-vregs src>> 1array ;
-M: ##slot uses-vregs [ obj>> ] [ slot>> ] bi 2array ;
-M: ##slot-imm uses-vregs obj>> 1array ;
-M: ##set-slot uses-vregs [ src>> ] [ obj>> ] [ slot>> ] tri 3array ;
-M: ##set-slot-imm uses-vregs [ src>> ] [ obj>> ] bi 2array ;
-M: ##string-nth uses-vregs [ obj>> ] [ index>> ] bi 2array ;
-M: ##set-string-nth-fast uses-vregs [ src>> ] [ obj>> ] [ index>> ] tri 3array ;
-M: ##conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
-M: ##compare-imm-branch uses-vregs src1>> 1array ;
-M: ##dispatch uses-vregs src>> 1array ;
-M: ##alien-getter uses-vregs src>> 1array ;
-M: ##alien-setter uses-vregs [ src>> ] [ value>> ] bi 2array ;
-M: ##fixnum-overflow uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
M: ##phi uses-vregs inputs>> values ;
-M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
-M: _compare-imm-branch uses-vregs src1>> 1array ;
-M: _dispatch uses-vregs src>> 1array ;
-M: insn uses-vregs drop f ;
+
+<PRIVATE
+
+: slot-array-quot ( slots -- quot )
+ [ reader-word 1quotation ] map dup length {
+ { 0 [ drop [ drop f ] ] }
+ { 1 [ first [ 1array ] compose ] }
+ { 2 [ first2 '[ _ _ bi 2array ] ] }
+ [ '[ _ cleave _ narray ] ]
+ } case ;
+
+: define-defs-vreg-method ( insn -- )
+ [ \ defs-vreg create-method ]
+ [ insn-def-slot [ name>> reader-word 1quotation ] [ [ drop f ] ] if* ] bi
+ define ;
+
+: define-uses-vregs-method ( insn -- )
+ [ \ uses-vregs create-method ]
+ [ insn-use-slots [ name>> ] map slot-array-quot ] bi
+ define ;
+
+: define-temp-vregs-method ( insn -- )
+ [ \ temp-vregs create-method ]
+ [ insn-temp-slots [ name>> ] map slot-array-quot ] bi
+ define ;
+
+PRIVATE>
+
+[
+ insn-classes get
+ [ [ define-defs-vreg-method ] each ]
+ [ { ##phi } diff [ define-uses-vregs-method ] each ]
+ [ [ define-temp-vregs-method ] each ]
+ tri
+] with-compilation-unit
! Computing def-use chains.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays kernel layouts math namespaces
-sequences classes.tuple cpu.architecture compiler.cfg.registers
-compiler.cfg.instructions ;
+USING: accessors arrays byte-arrays kernel layouts math
+namespaces sequences combinators splitting parser effects
+words cpu.architecture compiler.cfg.registers
+compiler.cfg.instructions compiler.cfg.instructions.syntax ;
IN: compiler.cfg.hats
-: ^^r ( -- vreg vreg ) next-vreg dup ; inline
-: ^^r1 ( obj -- vreg vreg obj ) [ ^^r ] dip ; inline
-: ^^r2 ( obj obj -- vreg vreg obj obj ) [ ^^r ] 2dip ; inline
-: ^^r3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^r ] 3dip ; inline
+<<
+
+<PRIVATE
+
+: hat-name ( insn -- word )
+ name>> "##" ?head drop "^^" prepend create-in ;
+
+: hat-quot ( insn -- quot )
+ [
+ "insn-slots" word-prop [ ] [
+ type>> {
+ { def [ [ next-vreg dup ] ] }
+ { temp [ [ next-vreg ] ] }
+ [ drop [ ] ]
+ } case swap [ dip ] curry compose
+ ] reduce
+ ] keep suffix ;
+
+: hat-effect ( insn -- effect )
+ "insn-slots" word-prop
+ [ type>> { def temp } memq? not ] filter [ name>> ] map
+ { "vreg" } <effect> ;
+
+: define-hat ( insn -- )
+ [ hat-name ] [ hat-quot ] [ hat-effect ] tri define-inline ;
+
+PRIVATE>
+
+insn-classes get [
+ dup [ insn-def-slot ] [ name>> "##" head? ] bi and
+ [ define-hat ] [ drop ] if
+] each
+
+>>
+
+: ^^load-literal ( obj -- dst )
+ [ next-vreg dup ] dip {
+ { [ dup not ] [ drop \ f tag-number ##load-immediate ] }
+ { [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
+ [ ##load-reference ]
+ } cond ; inline
+
+: ^^unbox-c-ptr ( src class -- dst )
+ [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ; inline
-: ^^load-literal ( obj -- dst ) ^^r1 ##load-literal ; inline
-: ^^copy ( src -- dst ) ^^r1 any-rep ##copy ; inline
-: ^^slot ( obj slot tag -- dst ) ^^r3 next-vreg ##slot ; inline
-: ^^slot-imm ( obj slot tag -- dst ) ^^r3 ##slot-imm ; inline
-: ^^set-slot ( src obj slot tag -- ) next-vreg ##set-slot ; inline
-: ^^string-nth ( obj index -- dst ) ^^r2 next-vreg ##string-nth ; inline
-: ^^add ( src1 src2 -- dst ) ^^r2 ##add ; inline
-: ^^add-imm ( src1 src2 -- dst ) ^^r2 ##add-imm ; inline
-: ^^sub ( src1 src2 -- dst ) ^^r2 ##sub ; inline
-: ^^sub-imm ( src1 src2 -- dst ) ^^r2 ##sub-imm ; inline
: ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline
-: ^^mul ( src1 src2 -- dst ) ^^r2 ##mul ; inline
-: ^^mul-imm ( src1 src2 -- dst ) ^^r2 ##mul-imm ; inline
-: ^^and ( input mask -- output ) ^^r2 ##and ; inline
-: ^^and-imm ( input mask -- output ) ^^r2 ##and-imm ; inline
-: ^^or ( src1 src2 -- dst ) ^^r2 ##or ; inline
-: ^^or-imm ( src1 src2 -- dst ) ^^r2 ##or-imm ; inline
-: ^^xor ( src1 src2 -- dst ) ^^r2 ##xor ; inline
-: ^^xor-imm ( src1 src2 -- dst ) ^^r2 ##xor-imm ; inline
-: ^^shl ( src1 src2 -- dst ) ^^r2 ##shl ; inline
-: ^^shl-imm ( src1 src2 -- dst ) ^^r2 ##shl-imm ; inline
-: ^^shr ( src1 src2 -- dst ) ^^r2 ##shr ; inline
-: ^^shr-imm ( src1 src2 -- dst ) ^^r2 ##shr-imm ; inline
-: ^^sar ( src1 src2 -- dst ) ^^r2 ##sar ; inline
-: ^^sar-imm ( src1 src2 -- dst ) ^^r2 ##sar-imm ; inline
-: ^^min ( src1 src2 -- dst ) ^^r2 ##min ; inline
-: ^^max ( src1 src2 -- dst ) ^^r2 ##max ; inline
-: ^^not ( src -- dst ) ^^r1 ##not ; inline
-: ^^log2 ( src -- dst ) ^^r1 ##log2 ; inline
-: ^^bignum>integer ( src -- dst ) ^^r1 next-vreg ##bignum>integer ; inline
-: ^^integer>bignum ( src -- dst ) ^^r1 next-vreg ##integer>bignum ; inline
-: ^^add-float ( src1 src2 -- dst ) ^^r2 ##add-float ; inline
-: ^^sub-float ( src1 src2 -- dst ) ^^r2 ##sub-float ; inline
-: ^^mul-float ( src1 src2 -- dst ) ^^r2 ##mul-float ; inline
-: ^^div-float ( src1 src2 -- dst ) ^^r2 ##div-float ; inline
-: ^^max-float ( src1 src2 -- dst ) ^^r2 ##max-float ; inline
-: ^^min-float ( src1 src2 -- dst ) ^^r2 ##min-float ; inline
-: ^^unary-float-function ( src func -- dst ) ^^r2 ##unary-float-function ; inline
-: ^^binary-float-function ( src1 src2 func -- dst ) ^^r3 ##binary-float-function ; inline
-: ^^sqrt ( src -- dst ) ^^r1 ##sqrt ; inline
-: ^^float>integer ( src -- dst ) ^^r1 ##float>integer ; inline
-: ^^integer>float ( src -- dst ) ^^r1 ##integer>float ; inline
-: ^^allot ( size class -- dst ) ^^r2 next-vreg ##allot ; inline
: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
-: ^^box-alien ( src -- dst ) ^^r1 next-vreg ##box-alien ; inline
-: ^^box-displaced-alien ( base displacement base-class -- dst )
- ^^r3 [ next-vreg next-vreg ] dip ##box-displaced-alien ; inline
-: ^^unbox-alien ( src -- dst ) ^^r1 ##unbox-alien ; inline
-: ^^unbox-c-ptr ( src class -- dst ) ^^r2 next-vreg ##unbox-c-ptr ;
-: ^^alien-unsigned-1 ( src -- dst ) ^^r1 ##alien-unsigned-1 ; inline
-: ^^alien-unsigned-2 ( src -- dst ) ^^r1 ##alien-unsigned-2 ; inline
-: ^^alien-unsigned-4 ( src -- dst ) ^^r1 ##alien-unsigned-4 ; inline
-: ^^alien-signed-1 ( src -- dst ) ^^r1 ##alien-signed-1 ; inline
-: ^^alien-signed-2 ( src -- dst ) ^^r1 ##alien-signed-2 ; inline
-: ^^alien-signed-4 ( src -- dst ) ^^r1 ##alien-signed-4 ; inline
-: ^^alien-cell ( src -- dst ) ^^r1 ##alien-cell ; inline
-: ^^alien-float ( src -- dst ) ^^r1 ##alien-float ; inline
-: ^^alien-double ( src -- dst ) ^^r1 ##alien-double ; inline
-: ^^alien-global ( symbol library -- dst ) ^^r2 ##alien-global ; inline
-: ^^compare ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare ; inline
-: ^^compare-imm ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-imm ; inline
-: ^^compare-float ( src1 src2 cc -- dst ) ^^r3 next-vreg ##compare-float ; inline
-: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline
-: ^^tag-fixnum ( src -- dst ) ^^r1 ##tag-fixnum ; inline
-: ^^untag-fixnum ( src -- dst ) ^^r1 ##untag-fixnum ; inline
-: ^^fixnum-add ( src1 src2 -- dst ) ^^r2 ##fixnum-add ; inline
-: ^^fixnum-sub ( src1 src2 -- dst ) ^^r2 ##fixnum-sub ; inline
-: ^^fixnum-mul ( src1 src2 -- dst ) ^^r2 ##fixnum-mul ; inline
-: ^^phi ( inputs -- dst ) ^^r1 ##phi ; inline
\ No newline at end of file
+: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; inline
+: ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; inline
+: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors arrays kernel sequences namespaces words
-math math.order layouts classes.algebra alien byte-arrays
-compiler.constants combinators compiler.cfg.registers
-compiler.cfg.instructions.syntax ;
+math math.order layouts classes.algebra classes.union
+compiler.units alien byte-arrays compiler.constants combinators
+compiler.cfg.registers compiler.cfg.instructions.syntax ;
IN: compiler.cfg.instructions
+<<
+SYMBOL: insn-classes
+V{ } clone insn-classes set-global
+>>
+
: new-insn ( ... class -- insn ) f swap boa ; inline
! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: insn ;
-! Instruction with no side effects; if 'out' is never read, we
-! can eliminate it.
-TUPLE: ##flushable < insn dst ;
+! Instructions which are referentially transparent; used for
+! value numbering
+TUPLE: pure-insn < insn ;
-! Instruction which is referentially transparent; we can replace
-! repeated computation with a reference to a previous value
-TUPLE: ##pure < ##flushable ;
+! Stack operations
+INSN: ##load-immediate
+def: dst/int-rep
+constant: val ;
-TUPLE: ##unary < ##pure src ;
-TUPLE: ##unary/temp < ##unary temp ;
-TUPLE: ##binary < ##pure src1 src2 ;
-TUPLE: ##binary-imm < ##pure src1 { src2 integer } ;
-TUPLE: ##commutative < ##binary ;
-TUPLE: ##commutative-imm < ##binary-imm ;
+INSN: ##load-reference
+def: dst/int-rep
+constant: obj ;
-! Instruction only used for its side effect, produces no values
-TUPLE: ##effect < insn src ;
+INSN: ##peek
+def: dst/int-rep
+literal: loc ;
-! Read/write ops: candidates for alias analysis
-TUPLE: ##read < ##flushable ;
-TUPLE: ##write < ##effect ;
+INSN: ##replace
+use: src/int-rep
+literal: loc ;
-TUPLE: ##alien-getter < ##flushable src ;
-TUPLE: ##alien-setter < ##effect value ;
+INSN: ##inc-d
+literal: n ;
-! Stack operations
-INSN: ##load-immediate < ##pure { val integer } ;
-INSN: ##load-reference < ##pure obj ;
+INSN: ##inc-r
+literal: n ;
-GENERIC: ##load-literal ( dst value -- )
-
-M: fixnum ##load-literal tag-fixnum ##load-immediate ;
-M: f ##load-literal drop \ f tag-number ##load-immediate ;
-M: object ##load-literal ##load-reference ;
+! Subroutine calls
+INSN: ##call
+literal: word ;
-INSN: ##peek < ##flushable { loc loc } ;
-INSN: ##replace < ##effect { loc loc } ;
-INSN: ##inc-d { n integer } ;
-INSN: ##inc-r { n integer } ;
+INSN: ##jump
+literal: word ;
-! Subroutine calls
-INSN: ##call word ;
-INSN: ##jump word ;
INSN: ##return ;
! Dummy instruction that simply inhibits TCO
INSN: ##no-tco ;
! Jump tables
-INSN: ##dispatch src temp ;
+INSN: ##dispatch
+use: src/int-rep
+temp: temp/int-rep ;
! Slot access
-INSN: ##slot < ##read obj slot { tag integer } temp ;
-INSN: ##slot-imm < ##read obj { slot integer } { tag integer } ;
-INSN: ##set-slot < ##write obj slot { tag integer } temp ;
-INSN: ##set-slot-imm < ##write obj { slot integer } { tag integer } ;
+INSN: ##slot
+def: dst/int-rep
+use: obj/int-rep slot/int-rep
+literal: tag
+temp: temp/int-rep ;
+
+INSN: ##slot-imm
+def: dst/int-rep
+use: obj/int-rep
+literal: slot tag ;
+
+INSN: ##set-slot
+use: src/int-rep obj/int-rep slot/int-rep
+literal: tag
+temp: temp/int-rep ;
+
+INSN: ##set-slot-imm
+use: src/int-rep obj/int-rep
+literal: slot tag ;
! String element access
-INSN: ##string-nth < ##flushable obj index temp ;
-INSN: ##set-string-nth-fast < ##effect obj index temp ;
+INSN: ##string-nth
+def: dst/int-rep
+use: obj/int-rep index/int-rep
+temp: temp/int-rep ;
+
+INSN: ##set-string-nth-fast
+use: src/int-rep obj/int-rep index/int-rep
+temp: temp/int-rep ;
+
+PURE-INSN: ##copy
+def: dst
+use: src
+literal: rep ;
! Integer arithmetic
-INSN: ##add < ##commutative ;
-INSN: ##add-imm < ##commutative-imm ;
-INSN: ##sub < ##binary ;
-INSN: ##sub-imm < ##binary-imm ;
-INSN: ##mul < ##commutative ;
-INSN: ##mul-imm < ##commutative-imm ;
-INSN: ##and < ##commutative ;
-INSN: ##and-imm < ##commutative-imm ;
-INSN: ##or < ##commutative ;
-INSN: ##or-imm < ##commutative-imm ;
-INSN: ##xor < ##commutative ;
-INSN: ##xor-imm < ##commutative-imm ;
-INSN: ##shl < ##binary ;
-INSN: ##shl-imm < ##binary-imm ;
-INSN: ##shr < ##binary ;
-INSN: ##shr-imm < ##binary-imm ;
-INSN: ##sar < ##binary ;
-INSN: ##sar-imm < ##binary-imm ;
-INSN: ##min < ##binary ;
-INSN: ##max < ##binary ;
-INSN: ##not < ##unary ;
-INSN: ##log2 < ##unary ;
-
-: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
-: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
+PURE-INSN: ##add
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##add-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##sub
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##sub-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##mul
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##mul-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##and
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##and-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##or
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##or-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##xor
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##xor-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##shl
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##shl-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##shr
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##shr-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##sar
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##sar-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2 ;
+
+PURE-INSN: ##min
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##max
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+PURE-INSN: ##not
+def: dst/int-rep
+use: src/int-rep ;
+
+PURE-INSN: ##log2
+def: dst/int-rep
+use: src/int-rep ;
! Bignum/integer conversion
-INSN: ##integer>bignum < ##unary/temp ;
-INSN: ##bignum>integer < ##unary/temp ;
+PURE-INSN: ##integer>bignum
+def: dst/int-rep
+use: src/int-rep
+temp: temp/int-rep ;
+
+PURE-INSN: ##bignum>integer
+def: dst/int-rep
+use: src/int-rep
+temp: temp/int-rep ;
! Float arithmetic
-INSN: ##add-float < ##commutative ;
-INSN: ##sub-float < ##binary ;
-INSN: ##mul-float < ##commutative ;
-INSN: ##div-float < ##binary ;
-INSN: ##min-float < ##binary ;
-INSN: ##max-float < ##binary ;
-INSN: ##sqrt < ##unary ;
+PURE-INSN: ##unbox-float
+def: dst/double-rep
+use: src/int-rep ;
+
+PURE-INSN: ##box-float
+def: dst/int-rep
+use: src/double-rep
+temp: temp/int-rep ;
+
+PURE-INSN: ##add-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##sub-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##mul-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##div-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##min-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##max-float
+def: dst/double-rep
+use: src1/double-rep src2/double-rep ;
+
+PURE-INSN: ##sqrt
+def: dst/double-rep
+use: src/double-rep ;
! libc intrinsics
-INSN: ##unary-float-function < ##unary func ;
-INSN: ##binary-float-function < ##binary func ;
+PURE-INSN: ##unary-float-function
+def: dst/double-rep
+use: src/double-rep
+literal: func ;
-! Float/integer conversion
-INSN: ##float>integer < ##unary ;
-INSN: ##integer>float < ##unary ;
+PURE-INSN: ##binary-float-function
+def: dst/double-rep
+use: src1/double-rep src2/double-rep
+literal: func ;
+
+! Single/double float conversion
+PURE-INSN: ##single>double-float
+def: dst/double-rep
+use: src/float-rep ;
-! Boxing and unboxing
-INSN: ##copy < ##unary rep ;
-INSN: ##unbox-float < ##unary ;
-INSN: ##unbox-any-c-ptr < ##unary/temp ;
-INSN: ##box-float < ##unary/temp ;
-INSN: ##box-alien < ##unary/temp ;
-INSN: ##box-displaced-alien < ##binary temp1 temp2 base-class ;
+PURE-INSN: ##double>single-float
+def: dst/float-rep
+use: src/double-rep ;
+
+! Float/integer conversion
+PURE-INSN: ##float>integer
+def: dst/int-rep
+use: src/double-rep ;
+
+PURE-INSN: ##integer>float
+def: dst/double-rep
+use: src/int-rep ;
+
+! SIMD operations
+
+PURE-INSN: ##box-vector
+def: dst/int-rep
+use: src
+literal: rep
+temp: temp/int-rep ;
+
+PURE-INSN: ##unbox-vector
+def: dst
+use: src/int-rep
+literal: rep ;
+
+PURE-INSN: ##broadcast-vector
+def: dst
+use: src/scalar-rep
+literal: rep ;
+
+PURE-INSN: ##gather-vector-2
+def: dst
+use: src1/scalar-rep src2/scalar-rep
+literal: rep ;
+
+PURE-INSN: ##gather-vector-4
+def: dst
+use: src1/scalar-rep src2/scalar-rep src3/scalar-rep src4/scalar-rep
+literal: rep ;
+
+PURE-INSN: ##add-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##sub-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##mul-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##div-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##min-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##max-vector
+def: dst
+use: src1 src2
+literal: rep ;
+
+PURE-INSN: ##sqrt-vector
+def: dst
+use: src
+literal: rep ;
+
+PURE-INSN: ##horizontal-add-vector
+def: dst/scalar-rep
+use: src
+literal: rep ;
+
+! Boxing and unboxing aliens
+PURE-INSN: ##box-alien
+def: dst/int-rep
+use: src/int-rep
+temp: temp/int-rep ;
+
+PURE-INSN: ##box-displaced-alien
+def: dst/int-rep
+use: displacement/int-rep base/int-rep
+temp: temp1/int-rep temp2/int-rep
+literal: base-class ;
+
+PURE-INSN: ##unbox-any-c-ptr
+def: dst/int-rep
+use: src/int-rep
+temp: temp/int-rep ;
: ##unbox-f ( dst src -- ) drop 0 ##load-immediate ;
: ##unbox-byte-array ( dst src -- ) byte-array-offset ##add-imm ;
-: ##unbox-alien ( dst src -- ) 3 object tag-number ##slot-imm ;
+
+PURE-INSN: ##unbox-alien
+def: dst/int-rep
+use: src/int-rep ;
: ##unbox-c-ptr ( dst src class temp -- )
{
} cond ;
! Alien accessors
-INSN: ##alien-unsigned-1 < ##alien-getter ;
-INSN: ##alien-unsigned-2 < ##alien-getter ;
-INSN: ##alien-unsigned-4 < ##alien-getter ;
-INSN: ##alien-signed-1 < ##alien-getter ;
-INSN: ##alien-signed-2 < ##alien-getter ;
-INSN: ##alien-signed-4 < ##alien-getter ;
-INSN: ##alien-cell < ##alien-getter ;
-INSN: ##alien-float < ##alien-getter ;
-INSN: ##alien-double < ##alien-getter ;
-
-INSN: ##set-alien-integer-1 < ##alien-setter ;
-INSN: ##set-alien-integer-2 < ##alien-setter ;
-INSN: ##set-alien-integer-4 < ##alien-setter ;
-INSN: ##set-alien-cell < ##alien-setter ;
-INSN: ##set-alien-float < ##alien-setter ;
-INSN: ##set-alien-double < ##alien-setter ;
+INSN: ##alien-unsigned-1
+def: dst/int-rep
+use: src/int-rep ;
-! Memory allocation
-INSN: ##allot < ##flushable size class temp ;
+INSN: ##alien-unsigned-2
+def: dst/int-rep
+use: src/int-rep ;
-UNION: ##allocation
-##allot
-##box-float
-##box-alien
-##box-displaced-alien
-##integer>bignum ;
+INSN: ##alien-unsigned-4
+def: dst/int-rep
+use: src/int-rep ;
+
+INSN: ##alien-signed-1
+def: dst/int-rep
+use: src/int-rep ;
+
+INSN: ##alien-signed-2
+def: dst/int-rep
+use: src/int-rep ;
+
+INSN: ##alien-signed-4
+def: dst/int-rep
+use: src/int-rep ;
+
+INSN: ##alien-cell
+def: dst/int-rep
+use: src/int-rep ;
-INSN: ##write-barrier < ##effect card# table ;
+INSN: ##alien-float
+def: dst/float-rep
+use: src/int-rep ;
-INSN: ##alien-global < ##flushable symbol library ;
+INSN: ##alien-double
+def: dst/double-rep
+use: src/int-rep ;
+
+INSN: ##alien-vector
+def: dst
+use: src/int-rep
+literal: rep ;
+
+INSN: ##set-alien-integer-1
+use: src/int-rep value/int-rep ;
+
+INSN: ##set-alien-integer-2
+use: src/int-rep value/int-rep ;
+
+INSN: ##set-alien-integer-4
+use: src/int-rep value/int-rep ;
+
+INSN: ##set-alien-cell
+use: src/int-rep value/int-rep ;
+
+INSN: ##set-alien-float
+use: src/int-rep value/float-rep ;
+
+INSN: ##set-alien-double
+use: src/int-rep value/double-rep ;
+
+INSN: ##set-alien-vector
+use: src/int-rep value
+literal: rep ;
+
+! Memory allocation
+INSN: ##allot
+def: dst/int-rep
+literal: size class
+temp: temp/int-rep ;
+
+INSN: ##write-barrier
+use: src/int-rep
+temp: card#/int-rep table/int-rep ;
+
+INSN: ##alien-global
+def: dst/int-rep
+literal: symbol library ;
! FFI
-INSN: ##alien-invoke params stack-frame ;
-INSN: ##alien-indirect params stack-frame ;
-INSN: ##alien-callback params stack-frame ;
-INSN: ##callback-return params ;
+INSN: ##alien-invoke
+literal: params stack-frame ;
+
+INSN: ##alien-indirect
+literal: params stack-frame ;
+
+INSN: ##alien-callback
+literal: params stack-frame ;
+
+INSN: ##callback-return
+literal: params ;
! Instructions used by CFG IR only.
INSN: ##prologue ;
INSN: ##branch ;
-INSN: ##phi < ##pure inputs ;
+INSN: ##phi
+def: dst
+literal: inputs ;
! Conditionals
-TUPLE: ##conditional-branch < insn src1 src2 cc ;
+INSN: ##compare-branch
+use: src1/int-rep src2/int-rep
+literal: cc ;
+
+INSN: ##compare-imm-branch
+use: src1/int-rep
+constant: src2
+literal: cc ;
+
+PURE-INSN: ##compare
+def: dst/int-rep
+use: src1/int-rep src2/int-rep
+literal: cc
+temp: temp/int-rep ;
+
+PURE-INSN: ##compare-imm
+def: dst/int-rep
+use: src1/int-rep
+constant: src2
+literal: cc
+temp: temp/int-rep ;
+
+INSN: ##compare-float-branch
+use: src1/double-rep src2/double-rep
+literal: cc ;
+
+PURE-INSN: ##compare-float
+def: dst/int-rep
+use: src1/double-rep src2/double-rep
+literal: cc
+temp: temp/int-rep ;
-INSN: ##compare-branch < ##conditional-branch ;
-INSN: ##compare-imm-branch src1 { src2 integer } cc ;
+! Overflowing arithmetic
+INSN: ##fixnum-add
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
-INSN: ##compare < ##binary cc temp ;
-INSN: ##compare-imm < ##binary-imm cc temp ;
+INSN: ##fixnum-sub
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
-INSN: ##compare-float-branch < ##conditional-branch ;
-INSN: ##compare-float < ##binary cc temp ;
+INSN: ##fixnum-mul
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
-! Overflowing arithmetic
-TUPLE: ##fixnum-overflow < insn dst src1 src2 ;
-INSN: ##fixnum-add < ##fixnum-overflow ;
-INSN: ##fixnum-sub < ##fixnum-overflow ;
-INSN: ##fixnum-mul < ##fixnum-overflow ;
-
-INSN: ##gc temp1 temp2 data-values tagged-values uninitialized-locs ;
+INSN: ##gc
+temp: temp1/int-rep temp2/int-rep
+literal: data-values tagged-values uninitialized-locs ;
! Instructions used by machine IR only.
-INSN: _prologue stack-frame ;
-INSN: _epilogue stack-frame ;
+INSN: _prologue
+literal: stack-frame ;
+
+INSN: _epilogue
+literal: stack-frame ;
-INSN: _label id ;
+INSN: _label
+literal: label ;
+
+INSN: _branch
+literal: label ;
-INSN: _branch label ;
INSN: _loop-entry ;
-INSN: _dispatch src temp ;
-INSN: _dispatch-label label ;
+INSN: _dispatch
+use: src/int-rep
+temp: temp ;
+
+INSN: _dispatch-label
+literal: label ;
-TUPLE: _conditional-branch < insn label src1 src2 cc ;
+INSN: _compare-branch
+literal: label
+use: src1/int-rep src2/int-rep
+literal: cc ;
-INSN: _compare-branch < _conditional-branch ;
-INSN: _compare-imm-branch label src1 { src2 integer } cc ;
+INSN: _compare-imm-branch
+literal: label
+use: src1/int-rep
+constant: src2
+literal: cc ;
-INSN: _compare-float-branch < _conditional-branch ;
+INSN: _compare-float-branch
+literal: label
+use: src1/int-rep src2/int-rep
+literal: cc ;
! Overflowing arithmetic
-TUPLE: _fixnum-overflow < insn label dst src1 src2 ;
-INSN: _fixnum-add < _fixnum-overflow ;
-INSN: _fixnum-sub < _fixnum-overflow ;
-INSN: _fixnum-mul < _fixnum-overflow ;
+INSN: _fixnum-add
+literal: label
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+INSN: _fixnum-sub
+literal: label
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
+
+INSN: _fixnum-mul
+literal: label
+def: dst/int-rep
+use: src1/int-rep src2/int-rep ;
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
-INSN: _gc temp1 temp2 data-values tagged-values uninitialized-locs ;
+INSN: _gc
+temp: temp1 temp2
+literal: data-values tagged-values uninitialized-locs ;
! These instructions operate on machine registers and not
! virtual registers
-INSN: _spill src rep n ;
-INSN: _reload dst rep n ;
-INSN: _spill-area-size n ;
-
-! Instructions that use vregs
-UNION: vreg-insn
- ##flushable
- ##write-barrier
- ##dispatch
- ##effect
- ##fixnum-overflow
- ##conditional-branch
- ##compare-imm-branch
- ##phi
- ##gc
- _conditional-branch
- _compare-imm-branch
- _dispatch ;
+INSN: _spill
+use: src
+literal: rep n ;
+
+INSN: _reload
+def: dst
+literal: rep n ;
+
+INSN: _spill-area-size
+literal: n ;
+
+UNION: ##allocation
+##allot
+##box-float
+##box-vector
+##box-alien
+##box-displaced-alien
+##integer>bignum ;
+
+! For alias analysis
+UNION: ##read ##slot ##slot-imm ;
+UNION: ##write ##set-slot ##set-slot-imm ;
! Instructions that kill all live vregs but cannot trigger GC
UNION: partial-sync-insn
- ##unary-float-function
- ##binary-float-function ;
+##unary-float-function
+##binary-float-function ;
! Instructions that kill all live vregs
UNION: kill-vreg-insn
- ##call
- ##prologue
- ##epilogue
- ##alien-invoke
- ##alien-indirect
- ##alien-callback ;
-
-! Instructions that output floats
-UNION: output-float-insn
- ##add-float
- ##sub-float
- ##mul-float
- ##div-float
- ##min-float
- ##max-float
- ##sqrt
- ##unary-float-function
- ##binary-float-function
- ##integer>float
- ##unbox-float
- ##alien-float
- ##alien-double ;
-
-! Instructions that take floats as inputs
-UNION: input-float-insn
- ##add-float
- ##sub-float
- ##mul-float
- ##div-float
- ##min-float
- ##max-float
- ##sqrt
- ##unary-float-function
- ##binary-float-function
- ##float>integer
- ##box-float
- ##set-alien-float
- ##set-alien-double
- ##compare-float
- ##compare-float-branch ;
-
-! Smackdown
-INTERSECTION: ##unary-float ##unary input-float-insn ;
-INTERSECTION: ##binary-float ##binary input-float-insn ;
+##call
+##prologue
+##epilogue
+##alien-invoke
+##alien-indirect
+##alien-callback ;
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers
UNION: def-is-use-insn
- ##integer>bignum
- ##bignum>integer
- ##unbox-any-c-ptr ;
\ No newline at end of file
+##integer>bignum
+##bignum>integer
+##unbox-any-c-ptr ;
+
+SYMBOL: vreg-insn
+
+[
+ vreg-insn
+ insn-classes get [
+ "insn-slots" word-prop [ type>> { def use temp } memq? ] any?
+ ] filter
+ define-union-class
+] with-compilation-unit
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.tuple classes.tuple.parser kernel words
-make fry sequences parser accessors effects ;
+make fry sequences parser accessors effects namespaces
+combinators splitting classes.parser lexer quotations ;
IN: compiler.cfg.instructions.syntax
+SYMBOLS: def use temp literal constant ;
+
+SYMBOL: scalar-rep
+
+TUPLE: insn-slot-spec type name rep ;
+
+: parse-rep ( str/f -- rep )
+ {
+ { [ dup not ] [ ] }
+ { [ dup "scalar-rep" = ] [ drop scalar-rep ] }
+ [ "cpu.architecture" lookup ]
+ } cond ;
+
+: parse-insn-slot-spec ( type string -- spec )
+ over [ "Missing type" throw ] unless
+ "/" split1 parse-rep
+ insn-slot-spec boa ;
+
+: parse-insn-slot-specs ( seq -- specs )
+ [
+ f [
+ {
+ { "def:" [ drop def ] }
+ { "use:" [ drop use ] }
+ { "temp:" [ drop temp ] }
+ { "literal:" [ drop literal ] }
+ { "constant:" [ drop constant ] }
+ [ dupd parse-insn-slot-spec , ]
+ } case
+ ] reduce drop
+ ] { } make ;
+
+: insn-def-slot ( class -- slot/f )
+ "insn-slots" word-prop
+ [ type>> def eq? ] find nip ;
+
+: insn-use-slots ( class -- slot/f )
+ "insn-slots" word-prop
+ [ type>> use eq? ] filter ;
+
+: insn-temp-slots ( class -- slot/f )
+ "insn-slots" word-prop
+ [ type>> temp eq? ] filter ;
+
+! We cannot reference words in compiler.cfg.instructions directly
+! since that would create circularity.
+: insn-classes-word ( -- word )
+ "insn-classes" "compiler.cfg.instructions" lookup ;
+
: insn-word ( -- word )
- #! We want to put the insn tuple in compiler.cfg.instructions,
- #! but we cannot have circularity between that vocabulary and
- #! this one.
"insn" "compiler.cfg.instructions" lookup ;
+: pure-insn-word ( -- word )
+ "pure-insn" "compiler.cfg.instructions" lookup ;
+
: insn-effect ( word -- effect )
boa-effect in>> but-last f <effect> ;
-SYNTAX: INSN:
- parse-tuple-definition "insn#" suffix
- [ dup tuple eq? [ drop insn-word ] when ] dip
- [ define-tuple-class ]
- [ 2drop save-location ]
- [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
- 3tri ;
+: define-insn-tuple ( class superclass specs -- )
+ [ name>> ] map "insn#" suffix define-tuple-class ;
+
+: define-insn-ctor ( class specs -- )
+ [ dup '[ _ ] [ f ] [ boa , ] surround ] dip
+ [ name>> ] map f <effect> define-declared ;
+
+: define-insn ( class superclass specs -- )
+ parse-insn-slot-specs {
+ [ nip "insn-slots" set-word-prop ]
+ [ 2drop insn-classes-word get push ]
+ [ define-insn-tuple ]
+ [ 2drop save-location ]
+ [ nip define-insn-ctor ]
+ } 3cleave ;
+
+SYNTAX: INSN: CREATE-CLASS insn-word ";" parse-tokens define-insn ;
+
+SYNTAX: PURE-INSN: CREATE-CLASS pure-insn-word ";" parse-tokens define-insn ;
^^box-displaced-alien ds-push
] [ emit-primitive ] if ;
-: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
- ds-drop [ ds-pop swap ^^unbox-c-ptr ] dip ^^add-imm ;
-
-: (prepare-alien-accessor) ( class -- offset-vreg )
- [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
-
-: prepare-alien-accessor ( infos -- offset-vreg )
- <reversed> [ second class>> ] [ first ] bi
- dup value-info-small-fixnum? [
- literal>> (prepare-alien-accessor-imm)
- ] [ drop (prepare-alien-accessor) ] if ;
-
:: inline-alien ( node quot test -- )
[let | infos [ node node-input-infos ] |
infos test call
- [ infos prepare-alien-accessor quot call ]
+ [ infos quot call ]
[ node emit-primitive ]
if
] ; inline
[ second class>> fixnum class<= ]
bi and ;
+: prepare-alien-accessor ( info -- offset-vreg )
+ class>> [ 2inputs ^^untag-fixnum swap ] dip ^^unbox-c-ptr ^^add ;
+
+: prepare-alien-getter ( infos -- offset-vreg )
+ first prepare-alien-accessor ;
+
: inline-alien-getter ( node quot -- )
- '[ @ ds-push ]
+ '[ prepare-alien-getter @ ds-push ]
[ inline-alien-getter? ] inline-alien ; inline
: inline-alien-setter? ( infos class -- ? )
[ third class>> fixnum class<= ]
tri and and ;
+: prepare-alien-setter ( infos -- offset-vreg )
+ second prepare-alien-accessor ;
+
: inline-alien-integer-setter ( node quot -- )
- '[ ds-pop ^^untag-fixnum @ ]
+ '[ prepare-alien-setter ds-pop ^^untag-fixnum @ ]
[ fixnum inline-alien-setter? ]
inline-alien ; inline
: inline-alien-cell-setter ( node quot -- )
- [ dup node-input-infos first class>> ] dip
- '[ ds-pop _ ^^unbox-c-ptr @ ]
+ '[ [ prepare-alien-setter ds-pop ] [ first class>> ] bi ^^unbox-c-ptr @ ]
[ pinned-c-ptr inline-alien-setter? ]
inline-alien ; inline
: inline-alien-float-setter ( node quot -- )
- '[ ds-pop @ ]
+ '[ prepare-alien-setter ds-pop @ ]
[ float inline-alien-setter? ]
inline-alien ; inline
: emit-alien-float-getter ( node rep -- )
'[
_ {
- { single-float-rep [ ^^alien-float ] }
- { double-float-rep [ ^^alien-double ] }
+ { float-rep [ ^^alien-float ] }
+ { double-rep [ ^^alien-double ] }
} case
] inline-alien-getter ;
: emit-alien-float-setter ( node rep -- )
'[
_ {
- { single-float-rep [ ##set-alien-float ] }
- { double-float-rep [ ##set-alien-double ] }
+ { float-rep [ ##set-alien-float ] }
+ { double-rep [ ##set-alien-double ] }
} case
] inline-alien-float-setter ;
! See http://factorcode.org/license.txt for BSD license.
USING: sequences accessors layouts kernel math math.intervals
namespaces combinators fry arrays
+cpu.architecture
compiler.tree.propagation.info
compiler.cfg.hats
compiler.cfg.stacks
: emit-fixnum-overflow-op ( quot word -- )
! Inputs to the final instruction need to be copied because
! of loc>vreg sync
- [ [ (2inputs) [ ^^copy ] bi@ ] dip call ] dip
+ [ [ (2inputs) [ any-rep ^^copy ] bi@ ] dip call ] dip
[ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
emit-conditional ; inline
compiler.cfg.intrinsics.allot
compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float
+compiler.cfg.intrinsics.simd
compiler.cfg.intrinsics.slots
compiler.cfg.intrinsics.misc
compiler.cfg.comparisons ;
QUALIFIED: math.private
QUALIFIED: math.integers.private
QUALIFIED: math.floats.private
+QUALIFIED: math.vectors.simd.intrinsics
QUALIFIED: math.libm
IN: compiler.cfg.intrinsics
{ math.private:float= [ drop cc= emit-float-comparison ] }
{ math.private:float>fixnum [ drop emit-float>fixnum ] }
{ math.private:fixnum>float [ drop emit-fixnum>float ] }
- { alien.accessors:alien-float [ single-float-rep emit-alien-float-getter ] }
- { alien.accessors:set-alien-float [ single-float-rep emit-alien-float-setter ] }
- { alien.accessors:alien-double [ double-float-rep emit-alien-float-getter ] }
- { alien.accessors:set-alien-double [ double-float-rep emit-alien-float-setter ] }
+ { alien.accessors:alien-float [ float-rep emit-alien-float-getter ] }
+ { alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] }
+ { alien.accessors:alien-double [ double-rep emit-alien-float-getter ] }
+ { alien.accessors:set-alien-double [ double-rep emit-alien-float-setter ] }
} enable-intrinsics ;
: enable-fsqrt ( -- )
{ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
} enable-intrinsics ;
+: enable-sse2-simd ( -- )
+ {
+ { math.vectors.simd.intrinsics:assert-positive [ drop ] }
+ { math.vectors.simd.intrinsics:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vmin) [ [ ^^min-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vmax) [ [ ^^max-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-binary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-broadcast) [ [ ^^broadcast-vector ] emit-unary-vector-op ] }
+ { math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
+ { math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
+ { math.vectors.simd.intrinsics:alien-vector [ emit-alien-vector ] }
+ { math.vectors.simd.intrinsics:set-alien-vector [ emit-set-alien-vector ] }
+ } enable-intrinsics ;
+
+: enable-sse3-simd ( -- )
+ {
+ { math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] }
+ } enable-intrinsics ;
+
: emit-intrinsic ( node word -- )
"intrinsic" word-prop call( node -- ) ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays fry cpu.architecture kernel
+sequences compiler.tree.propagation.info
+compiler.cfg.builder.blocks compiler.cfg.stacks
+compiler.cfg.stacks.local compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.intrinsics.alien ;
+IN: compiler.cfg.intrinsics.simd
+
+: emit-vector-op ( node quot: ( rep -- ) -- )
+ [ dup node-input-infos last literal>> ] dip over representation?
+ [ [ drop ] 2dip call ] [ 2drop emit-primitive ] if ; inline
+
+: emit-binary-vector-op ( node quot -- )
+ '[ [ ds-drop 2inputs ] dip @ ds-push ] emit-vector-op ; inline
+
+: emit-unary-vector-op ( node quot -- )
+ '[ [ ds-drop ds-pop ] dip @ ds-push ] emit-vector-op ; inline
+
+: emit-gather-vector-2 ( node -- )
+ [ ^^gather-vector-2 ] emit-binary-vector-op ;
+
+: emit-gather-vector-4 ( node -- )
+ [
+ ds-drop
+ [
+ D 3 peek-loc
+ D 2 peek-loc
+ D 1 peek-loc
+ D 0 peek-loc
+ -4 inc-d
+ ] dip
+ ^^gather-vector-4
+ ds-push
+ ] emit-vector-op ;
+
+: emit-alien-vector ( node -- )
+ dup [
+ '[
+ ds-drop prepare-alien-getter
+ _ ^^alien-vector ds-push
+ ]
+ [ inline-alien-getter? ] inline-alien
+ ] with emit-vector-op ;
+
+: emit-set-alien-vector ( node -- )
+ dup [
+ '[
+ ds-drop prepare-alien-setter ds-pop
+ _ ##set-alien-vector
+ ]
+ [ byte-array inline-alien-setter? ]
+ inline-alien
+ ] with emit-vector-op ;
: (emit-set-slot) ( infos -- obj-reg )
[ 3inputs ^^offset>slot ] [ second value-tag ] bi*
- pick [ ^^set-slot ] dip ;
+ pick [ next-vreg ##set-slot ] dip ;
: (emit-set-slot-imm) ( infos -- obj-reg )
ds-drop
[
[
2dup spill-on-gc?
- [ swap [ vreg-spill-slot ] [ rep-of ] bi 3array , ] [ 2drop ] if
+ [ swap [ rep-of ] [ vreg-spill-slot ] bi 3array , ] [ 2drop ] if
] assoc-each
] { } make ;
H{ } spill-slots set
H{
- { 1 single-float-rep }
- { 2 single-float-rep }
- { 3 single-float-rep }
+ { 1 float-rep }
+ { 2 float-rep }
+ { 3 float-rep }
} representations set
[
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: functors assocs kernel accessors compiler.cfg.instructions
-lexer parser ;
+USING: accessors arrays assocs fry functors generic.parser
+kernel lexer namespaces parser sequences slots words sets
+compiler.cfg.def-use compiler.cfg.instructions
+compiler.cfg.instructions.syntax ;
IN: compiler.cfg.renaming.functor
+: slot-change-quot ( slots quot -- quot' )
+ '[ [ _ ] dip changer-word [ ] 2sequence ] map [ ] join
+ [ drop ] append ;
+
FUNCTOR: define-renaming ( NAME DEF-QUOT USE-QUOT TEMP-QUOT -- )
rename-insn-defs DEFINES ${NAME}-insn-defs
GENERIC: rename-insn-defs ( insn -- )
-M: ##flushable rename-insn-defs
- DEF-QUOT change-dst
- drop ;
-
-M: ##fixnum-overflow rename-insn-defs
- DEF-QUOT change-dst
- drop ;
-
-M: _fixnum-overflow rename-insn-defs
- DEF-QUOT change-dst
- drop ;
-
-M: insn rename-insn-defs drop ;
+insn-classes get [
+ [ \ rename-insn-defs create-method-in ]
+ [ insn-def-slot dup [ name>> 1array ] when DEF-QUOT slot-change-quot ] bi
+ define
+] each
GENERIC: rename-insn-uses ( insn -- )
-M: ##effect rename-insn-uses
- USE-QUOT change-src
- drop ;
-
-M: ##unary rename-insn-uses
- USE-QUOT change-src
- drop ;
-
-M: ##binary rename-insn-uses
- USE-QUOT change-src1
- USE-QUOT change-src2
- drop ;
-
-M: ##binary-imm rename-insn-uses
- USE-QUOT change-src1
- drop ;
-
-M: ##slot rename-insn-uses
- USE-QUOT change-obj
- USE-QUOT change-slot
- drop ;
-
-M: ##slot-imm rename-insn-uses
- USE-QUOT change-obj
- drop ;
-
-M: ##set-slot rename-insn-uses
- dup call-next-method
- USE-QUOT change-obj
- USE-QUOT change-slot
- drop ;
-
-M: ##string-nth rename-insn-uses
- USE-QUOT change-obj
- USE-QUOT change-index
- drop ;
-
-M: ##set-string-nth-fast rename-insn-uses
- dup call-next-method
- USE-QUOT change-obj
- USE-QUOT change-index
- drop ;
-
-M: ##set-slot-imm rename-insn-uses
- dup call-next-method
- USE-QUOT change-obj
- drop ;
-
-M: ##alien-getter rename-insn-uses
- dup call-next-method
- USE-QUOT change-src
- drop ;
-
-M: ##alien-setter rename-insn-uses
- dup call-next-method
- USE-QUOT change-value
- drop ;
-
-M: ##conditional-branch rename-insn-uses
- USE-QUOT change-src1
- USE-QUOT change-src2
- drop ;
-
-M: ##compare-imm-branch rename-insn-uses
- USE-QUOT change-src1
- drop ;
-
-M: ##dispatch rename-insn-uses
- USE-QUOT change-src
- drop ;
-
-M: ##fixnum-overflow rename-insn-uses
- USE-QUOT change-src1
- USE-QUOT change-src2
- drop ;
+insn-classes get { ##phi } diff [
+ [ \ rename-insn-uses create-method-in ]
+ [ insn-use-slots [ name>> ] map USE-QUOT slot-change-quot ] bi
+ define
+] each
M: ##phi rename-insn-uses
- [ USE-QUOT assoc-map ] change-inputs
- drop ;
-
-M: insn rename-insn-uses drop ;
+ [ USE-QUOT assoc-map ] change-inputs drop ;
GENERIC: rename-insn-temps ( insn -- )
-M: ##write-barrier rename-insn-temps
- TEMP-QUOT change-card#
- TEMP-QUOT change-table
- drop ;
-
-M: ##unary/temp rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##allot rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##dispatch rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##slot rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##set-slot rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##string-nth rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##set-string-nth-fast rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##box-displaced-alien rename-insn-temps
- TEMP-QUOT change-temp1
- TEMP-QUOT change-temp2
- drop ;
-
-M: ##compare rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##compare-imm rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##compare-float rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: ##gc rename-insn-temps
- TEMP-QUOT change-temp1
- TEMP-QUOT change-temp2
- drop ;
-
-M: _dispatch rename-insn-temps
- TEMP-QUOT change-temp drop ;
-
-M: insn rename-insn-temps drop ;
+insn-classes get [
+ [ \ rename-insn-temps create-method-in ]
+ [ insn-temp-slots [ name>> ] map TEMP-QUOT slot-change-quot ] bi
+ define
+] each
;FUNCTOR
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences arrays fry namespaces
-cpu.architecture compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
-compiler.cfg.instructions compiler.cfg.def-use ;
+USING: kernel accessors sequences arrays fry namespaces generic
+words sets combinators generalizations cpu.architecture compiler.units
+compiler.cfg.utilities compiler.cfg compiler.cfg.rpo
+compiler.cfg.instructions compiler.cfg.instructions.syntax
+compiler.cfg.def-use ;
IN: compiler.cfg.representations.preferred
GENERIC: defs-vreg-rep ( insn -- rep/f )
GENERIC: temp-vreg-reps ( insn -- reps )
GENERIC: uses-vreg-reps ( insn -- reps )
-M: ##flushable defs-vreg-rep drop int-rep ;
-M: ##copy defs-vreg-rep rep>> ;
-M: output-float-insn defs-vreg-rep drop double-float-rep ;
-M: ##fixnum-overflow defs-vreg-rep drop int-rep ;
-M: _fixnum-overflow defs-vreg-rep drop int-rep ;
-M: ##phi defs-vreg-rep drop "##phi must be special-cased" throw ;
-M: insn defs-vreg-rep drop f ;
+<PRIVATE
-M: ##write-barrier temp-vreg-reps drop { int-rep int-rep } ;
-M: ##unary/temp temp-vreg-reps drop { int-rep } ;
-M: ##allot temp-vreg-reps drop { int-rep } ;
-M: ##dispatch temp-vreg-reps drop { int-rep } ;
-M: ##slot temp-vreg-reps drop { int-rep } ;
-M: ##set-slot temp-vreg-reps drop { int-rep } ;
-M: ##string-nth temp-vreg-reps drop { int-rep } ;
-M: ##set-string-nth-fast temp-vreg-reps drop { int-rep } ;
-M: ##box-displaced-alien temp-vreg-reps drop { int-rep int-rep } ;
-M: ##compare temp-vreg-reps drop { int-rep } ;
-M: ##compare-imm temp-vreg-reps drop { int-rep } ;
-M: ##compare-float temp-vreg-reps drop { int-rep } ;
-M: ##gc temp-vreg-reps drop { int-rep int-rep } ;
-M: _dispatch temp-vreg-reps drop { int-rep } ;
-M: insn temp-vreg-reps drop f ;
+: rep-getter-quot ( rep -- quot )
+ {
+ { f [ [ rep>> ] ] }
+ { scalar-rep [ [ rep>> scalar-rep-of ] ] }
+ [ [ drop ] swap suffix ]
+ } case ;
-M: ##copy uses-vreg-reps rep>> 1array ;
-M: ##unary uses-vreg-reps drop { int-rep } ;
-M: ##unary-float uses-vreg-reps drop { double-float-rep } ;
-M: ##binary uses-vreg-reps drop { int-rep int-rep } ;
-M: ##binary-imm uses-vreg-reps drop { int-rep } ;
-M: ##binary-float uses-vreg-reps drop { double-float-rep double-float-rep } ;
-M: ##effect uses-vreg-reps drop { int-rep } ;
-M: ##slot uses-vreg-reps drop { int-rep int-rep } ;
-M: ##slot-imm uses-vreg-reps drop { int-rep } ;
-M: ##set-slot uses-vreg-reps drop { int-rep int-rep int-rep } ;
-M: ##set-slot-imm uses-vreg-reps drop { int-rep int-rep } ;
-M: ##string-nth uses-vreg-reps drop { int-rep int-rep } ;
-M: ##set-string-nth-fast uses-vreg-reps drop { int-rep int-rep int-rep } ;
-M: ##compare-branch uses-vreg-reps drop { int-rep int-rep } ;
-M: ##compare-imm-branch uses-vreg-reps drop { int-rep } ;
-M: ##compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
-M: ##dispatch uses-vreg-reps drop { int-rep } ;
-M: ##alien-getter uses-vreg-reps drop { int-rep } ;
-M: ##alien-setter uses-vreg-reps drop { int-rep int-rep } ;
-M: ##set-alien-float uses-vreg-reps drop { int-rep double-float-rep } ;
-M: ##set-alien-double uses-vreg-reps drop { int-rep double-float-rep } ;
-M: ##fixnum-overflow uses-vreg-reps drop { int-rep int-rep } ;
-M: _compare-imm-branch uses-vreg-reps drop { int-rep } ;
-M: _compare-branch uses-vreg-reps drop { int-rep int-rep } ;
-M: _compare-float-branch uses-vreg-reps drop { double-float-rep double-float-rep } ;
-M: _dispatch uses-vreg-reps drop { int-rep } ;
-M: ##phi uses-vreg-reps drop "##phi must be special-cased" throw ;
-M: insn uses-vreg-reps drop f ;
+: define-defs-vreg-rep-method ( insn -- )
+ [ \ defs-vreg-rep create-method ]
+ [ insn-def-slot [ rep>> rep-getter-quot ] [ [ drop f ] ] if* ]
+ bi define ;
+
+: reps-getter-quot ( reps -- quot )
+ dup [ rep>> { f scalar-rep } memq? not ] all? [
+ [ rep>> ] map [ drop ] swap suffix
+ ] [
+ [ rep>> rep-getter-quot ] map dup length {
+ { 0 [ drop [ drop f ] ] }
+ { 1 [ first [ 1array ] compose ] }
+ { 2 [ first2 '[ _ _ bi 2array ] ] }
+ [ '[ _ cleave _ narray ] ]
+ } case
+ ] if ;
+
+: define-uses-vreg-reps-method ( insn -- )
+ [ \ uses-vreg-reps create-method ]
+ [ insn-use-slots reps-getter-quot ]
+ bi define ;
+
+: define-temp-vreg-reps-method ( insn -- )
+ [ \ temp-vreg-reps create-method ]
+ [ insn-temp-slots reps-getter-quot ]
+ bi define ;
+
+PRIVATE>
+
+[
+ insn-classes get
+ [ [ define-defs-vreg-rep-method ] each ]
+ [ { ##phi } diff [ define-uses-vreg-reps-method ] each ]
+ [ [ define-temp-vreg-reps-method ] each ]
+ tri
+] with-compilation-unit
: each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
[ [ defs-vreg ] [ defs-vreg-rep ] bi ] dip with when* ; inline
compiler.cfg.representations.preferred ;
IN: compiler.cfg.representations
-[ { double-float-rep double-float-rep } ] [
+[ { double-rep double-rep } ] [
T{ ##add-float
{ dst 5 }
{ src1 3 }
} uses-vreg-reps
] unit-test
-[ double-float-rep ] [
+[ double-rep ] [
T{ ##alien-double
{ dst 5 }
{ src 3 }
cpu.architecture compiler.utilities
compiler.cfg
compiler.cfg.rpo
+compiler.cfg.hats
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.def-use
! Virtual register representation selection.
+ERROR: bad-conversion dst src dst-rep src-rep ;
+
+GENERIC: emit-box ( dst src rep -- )
+GENERIC: emit-unbox ( dst src rep -- )
+
+M: float-rep emit-box
+ drop
+ [ double-rep next-vreg-rep dup ] dip ##single>double-float
+ int-rep next-vreg-rep ##box-float ;
+
+M: float-rep emit-unbox
+ drop
+ [ double-rep next-vreg-rep dup ] dip ##unbox-float
+ ##double>single-float ;
+
+M: double-rep emit-box
+ drop
+ int-rep next-vreg-rep ##box-float ;
+
+M: double-rep emit-unbox
+ drop ##unbox-float ;
+
+M: vector-rep emit-box
+ int-rep next-vreg-rep ##box-vector ;
+
+M: vector-rep emit-unbox
+ ##unbox-vector ;
+
: emit-conversion ( dst src dst-rep src-rep -- )
- 2array {
- { { int-rep int-rep } [ int-rep ##copy ] }
- { { double-float-rep double-float-rep } [ double-float-rep ##copy ] }
- { { double-float-rep int-rep } [ ##unbox-float ] }
- { { int-rep double-float-rep } [ int-rep next-vreg-rep ##box-float ] }
- } case ;
+ {
+ { [ 2dup eq? ] [ drop ##copy ] }
+ { [ dup int-rep eq? ] [ drop emit-unbox ] }
+ { [ over int-rep eq? ] [ nip emit-box ] }
+ [
+ 2dup 2array {
+ { { double-rep float-rep } [ 2drop ##single>double-float ] }
+ { { float-rep double-rep } [ 2drop ##double>single-float ] }
+ ! Punning SIMD vector types? Naughty naughty! But
+ ! it is allowed... otherwise bail out.
+ [
+ drop 2dup [ reg-class-of ] bi@ eq?
+ [ drop ##copy ] [ bad-conversion ] if
+ ]
+ } case
+ ]
+ } cond ;
<PRIVATE
[
V{
- T{ ##copy f 1 2 double-float-rep }
+ T{ ##copy f 1 2 double-rep }
T{ ##sub-float f 1 1 3 }
}
] [
H{
- { 1 double-float-rep }
- { 2 double-float-rep }
- { 3 double-float-rep }
+ { 1 double-rep }
+ { 2 double-rep }
+ { 3 double-rep }
} clone representations set
{
T{ ##sub-float f 1 2 3 }
[
V{
- T{ ##copy f 1 2 double-float-rep }
+ T{ ##copy f 1 2 double-rep }
T{ ##mul-float f 1 1 1 }
}
] [
H{
- { 1 double-float-rep }
- { 2 double-float-rep }
+ { 1 double-rep }
+ { 2 double-rep }
} clone representations set
{
T{ ##mul-float f 1 2 2 }
##sar-imm
##min
##max
- ##fixnum-overflow
+ ##fixnum-add
+ ##fixnum-sub
+ ##fixnum-mul
##add-float
##sub-float
##mul-float
##div-float
##min-float
- ##max-float ;
+ ##max-float
+ ##add-vector
+ ##sub-vector
+ ##mul-vector
+ ##div-vector
+ ##min-vector
+ ##max-vector ;
GENERIC: convert-two-operand* ( insn -- )
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes kernel math namespaces combinators
-combinators.short-circuit compiler.cfg.instructions
+USING: accessors classes classes.algebra classes.parser
+classes.tuple combinators combinators.short-circuit fry
+generic.parser kernel math namespaces quotations sequences slots
+splitting words compiler.cfg.instructions
+compiler.cfg.instructions.syntax
compiler.cfg.value-numbering.graph ;
IN: compiler.cfg.value-numbering.expressions
-! Referentially-transparent expressions
-TUPLE: unary-expr < expr in ;
-TUPLE: binary-expr < expr in1 in2 ;
-TUPLE: commutative-expr < binary-expr ;
-TUPLE: compare-expr < binary-expr cc ;
TUPLE: constant-expr < expr value ;
-TUPLE: reference-expr < expr value ;
-TUPLE: unary-float-function-expr < expr in func ;
-TUPLE: binary-float-function-expr < expr in1 in2 func ;
-TUPLE: box-displaced-alien-expr < expr displacement base base-class ;
-: <constant> ( constant -- expr )
- f swap constant-expr boa ; inline
+C: <constant> constant-expr
M: constant-expr equal?
over constant-expr? [
} 2&&
] [ 2drop f ] if ;
-: <reference> ( constant -- expr )
- f swap reference-expr boa ; inline
+TUPLE: reference-expr < expr value ;
+
+C: <reference> reference-expr
M: reference-expr equal?
over reference-expr? [
GENERIC: >expr ( insn -- expr )
+M: insn >expr drop next-input-expr ;
+
M: ##load-immediate >expr val>> <constant> ;
M: ##load-reference >expr obj>> <reference> ;
-M: ##unary >expr
- [ class ] [ src>> vreg>vn ] bi unary-expr boa ;
-
-M: ##binary >expr
- [ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
- binary-expr boa ;
-
-M: ##binary-imm >expr
- [ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
- binary-expr boa ;
-
-M: ##commutative >expr
- [ class ] [ src1>> vreg>vn ] [ src2>> vreg>vn ] tri
- commutative-expr boa ;
-
-M: ##commutative-imm >expr
- [ class ] [ src1>> vreg>vn ] [ src2>> constant>vn ] tri
- commutative-expr boa ;
-
-: compare>expr ( insn -- expr )
- {
- [ class ]
- [ src1>> vreg>vn ]
- [ src2>> vreg>vn ]
- [ cc>> ]
- } cleave compare-expr boa ; inline
-
-M: ##compare >expr compare>expr ;
-
-: compare-imm>expr ( insn -- expr )
- {
- [ class ]
- [ src1>> vreg>vn ]
- [ src2>> constant>vn ]
- [ cc>> ]
- } cleave compare-expr boa ; inline
-
-M: ##compare-imm >expr compare-imm>expr ;
-
-M: ##compare-float >expr compare>expr ;
-
-M: ##box-displaced-alien >expr
- {
- [ class ]
- [ src1>> vreg>vn ]
- [ src2>> vreg>vn ]
- [ base-class>> ]
- } cleave box-displaced-alien-expr boa ;
-
-M: ##unary-float-function >expr
- [ class ] [ src>> vreg>vn ] [ func>> ] tri
- unary-float-function-expr boa ;
-
-M: ##binary-float-function >expr
- {
- [ class ]
- [ src1>> vreg>vn ]
- [ src2>> vreg>vn ]
- [ func>> ]
- } cleave
- binary-float-function-expr boa ;
-
-M: ##flushable >expr drop next-input-expr ;
-
-: init-expressions ( -- )
- 0 input-expr-counter set ;
+<<
+
+: input-values ( slot-specs -- slot-specs' )
+ [ type>> { use literal constant } memq? ] filter ;
+
+: expr-class ( insn -- expr )
+ name>> "##" ?head drop "-expr" append create-class-in ;
+
+: define-expr-class ( insn expr slot-specs -- )
+ [ nip expr ] dip [ name>> ] map define-tuple-class ;
+
+: >expr-quot ( expr slot-specs -- quot )
+ [
+ [ name>> reader-word 1quotation ]
+ [
+ type>> {
+ { use [ [ vreg>vn ] ] }
+ { literal [ [ ] ] }
+ { constant [ [ constant>vn ] ] }
+ } case
+ ] bi append
+ ] map cleave>quot swap suffix \ boa suffix ;
+
+: define->expr-method ( insn expr slot-specs -- )
+ [ 2drop \ >expr create-method-in ] [ >expr-quot nip ] 3bi define ;
+
+: handle-pure-insn ( insn -- )
+ [ ] [ expr-class ] [ "insn-slots" word-prop input-values ] tri
+ [ define-expr-class ] [ define->expr-method ] 3bi ;
+
+insn-classes get [ pure-insn class<= ] filter [ handle-pure-insn ] each
+
+>>
! biassoc mapping expressions to value numbers
SYMBOL: exprs>vns
-TUPLE: expr op ;
+TUPLE: expr ;
: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
SYMBOL: input-expr-counter
: next-input-expr ( -- expr )
- f input-expr-counter counter input-expr boa ;
+ input-expr-counter counter input-expr boa ;
SYMBOL: vregs>vns
: init-value-graph ( -- )
0 vn-counter set
+ 0 input-expr-counter set
<bihash> exprs>vns set
<bihash> vregs>vns set ;
} 1&&
] [ drop f ] if ; inline
+: general-compare-expr? ( insn -- ? )
+ { [ compare-expr? ] [ compare-imm-expr? ] [ compare-float-expr? ] } 1|| ;
+
: rewrite-boolean-comparison? ( insn -- ? )
dup ##branch-t? [
- src1>> vreg>expr compare-expr?
+ src1>> vreg>expr general-compare-expr?
] [ drop f ] if ; inline
: >compare-expr< ( expr -- in1 in2 cc )
- [ in1>> vn>vreg ] [ in2>> vn>vreg ] [ cc>> ] tri ; inline
+ [ src1>> vn>vreg ] [ src2>> vn>vreg ] [ cc>> ] tri ; inline
: >compare-imm-expr< ( expr -- in1 in2 cc )
- [ in1>> vn>vreg ] [ in2>> vn>constant ] [ cc>> ] tri ; inline
+ [ src1>> vn>vreg ] [ src2>> vn>constant ] [ cc>> ] tri ; inline
: rewrite-boolean-comparison ( expr -- insn )
- src1>> vreg>expr dup op>> {
- { \ ##compare [ >compare-expr< \ ##compare-branch new-insn ] }
- { \ ##compare-imm [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
- { \ ##compare-float [ >compare-expr< \ ##compare-float-branch new-insn ] }
- } case ;
+ src1>> vreg>expr {
+ { [ dup compare-expr? ] [ >compare-expr< \ ##compare-branch new-insn ] }
+ { [ dup compare-imm-expr? ] [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
+ { [ dup compare-float-expr? ] [ >compare-expr< \ ##compare-float-branch new-insn ] }
+ } cond ;
: tag-fixnum-expr? ( expr -- ? )
- dup op>> \ ##shl-imm eq?
- [ in2>> vn>constant tag-bits get = ] [ drop f ] if ;
+ dup shl-imm-expr?
+ [ src2>> vn>constant tag-bits get = ] [ drop f ] if ;
: rewrite-tagged-comparison? ( insn -- ? )
#! Are we comparing two tagged fixnums? Then untag them.
tag-bits get neg shift ; inline
: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
- [ src1>> vreg>expr in1>> vn>vreg ]
+ [ src1>> vreg>expr src1>> vn>vreg ]
[ src2>> tagged>constant ]
[ cc>> ]
tri ; inline
: rewrite-redundant-comparison? ( insn -- ? )
{
- [ src1>> vreg>expr compare-expr? ]
+ [ src1>> vreg>expr general-compare-expr? ]
[ src2>> \ f tag-number = ]
[ cc>> { cc= cc/= } memq? ]
} 1&& ; inline
: rewrite-redundant-comparison ( insn -- insn' )
- [ cc>> ] [ dst>> ] [ src1>> vreg>expr dup op>> ] tri {
- { \ ##compare [ >compare-expr< next-vreg \ ##compare new-insn ] }
- { \ ##compare-imm [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
- { \ ##compare-float [ >compare-expr< next-vreg \ ##compare-float new-insn ] }
- } case
+ [ cc>> ] [ dst>> ] [ src1>> vreg>expr ] tri {
+ { [ dup compare-expr? ] [ >compare-expr< next-vreg \ ##compare new-insn ] }
+ { [ dup compare-imm-expr? ] [ >compare-imm-expr< next-vreg \ ##compare-imm new-insn ] }
+ { [ dup compare-float-expr? ] [ >compare-expr< next-vreg \ ##compare-float new-insn ] }
+ } cond
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
ERROR: bad-comparison ;
[ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi
\ ##load-immediate new-insn ; inline
-: reassociate? ( insn -- ? )
- [ src1>> vreg>expr op>> ] [ class ] bi = ; inline
-
: reassociate ( insn op -- insn )
[
{
[ dst>> ]
- [ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ]
+ [ src1>> vreg>expr [ src1>> vn>vreg ] [ src2>> vn>constant ] bi ]
[ src2>> ]
[ ]
} cleave constant-fold*
M: ##add-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
- { [ dup reassociate? ] [ \ ##add-imm reassociate ] }
+ { [ dup src1>> vreg>expr add-imm-expr? ] [ \ ##add-imm reassociate ] }
[ drop f ]
} cond ;
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup strength-reduce-mul? ] [ strength-reduce-mul ] }
- { [ dup reassociate? ] [ \ ##mul-imm reassociate ] }
+ { [ dup src1>> vreg>expr mul-imm-expr? ] [ \ ##mul-imm reassociate ] }
[ drop f ]
} cond ;
M: ##and-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
- { [ dup reassociate? ] [ \ ##and-imm reassociate ] }
+ { [ dup src1>> vreg>expr and-imm-expr? ] [ \ ##and-imm reassociate ] }
[ drop f ]
} cond ;
M: ##or-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
- { [ dup reassociate? ] [ \ ##or-imm reassociate ] }
+ { [ dup src1>> vreg>expr or-imm-expr? ] [ \ ##or-imm reassociate ] }
[ drop f ]
} cond ;
M: ##xor-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
- { [ dup reassociate? ] [ \ ##xor-imm reassociate ] }
+ { [ dup src1>> vreg>expr xor-imm-expr? ] [ \ ##xor-imm reassociate ] }
[ drop f ]
} cond ;
M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;
-: box-displaced-alien? ( expr -- ? )
- op>> \ ##box-displaced-alien eq? ;
-
! ##box-displaced-alien f 1 2 3 <class>
! ##unbox-c-ptr 4 1 <class>
! =>
] { } make ;
M: ##unbox-any-c-ptr rewrite
- dup src>> vreg>expr dup box-displaced-alien?
+ dup src>> vreg>expr dup box-displaced-alien-expr?
[ rewrite-unbox-displaced-alien ] [ 2drop f ] if ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators classes math layouts
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.expressions locals ;
+compiler.cfg.value-numbering.expressions ;
IN: compiler.cfg.value-numbering.simplify
! Return value of f means we didn't simplify.
GENERIC: simplify* ( expr -- vn/expr/f )
-: simplify-unbox-alien ( in -- vn/expr/f )
- dup op>> \ ##box-alien eq? [ in>> ] [ drop f ] if ; inline
+M: copy-expr simplify* src>> ;
-M: unary-expr simplify*
- #! Note the copy propagation: a copy always simplifies to
- #! its source VN.
- [ in>> vn>expr ] [ op>> ] bi {
- { \ ##copy [ ] }
- { \ ##unbox-alien [ simplify-unbox-alien ] }
- { \ ##unbox-any-c-ptr [ simplify-unbox-alien ] }
- [ 2drop f ]
- } case ;
+: simplify-unbox-alien ( expr -- vn/expr/f )
+ src>> vn>expr dup box-alien-expr? [ src>> ] [ drop f ] if ;
+
+M: unbox-alien-expr simplify* simplify-unbox-alien ;
+
+M: unbox-any-c-ptr-expr simplify* simplify-unbox-alien ;
-: expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline
+: expr-zero? ( expr -- ? ) T{ constant-expr f 0 } = ; inline
-: expr-one? ( expr -- ? ) T{ constant-expr f f 1 } = ; inline
+: expr-one? ( expr -- ? ) T{ constant-expr f 1 } = ; inline
: >binary-expr< ( expr -- in1 in2 )
- [ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline
+ [ src1>> vn>expr ] [ src2>> vn>expr ] bi ; inline
: simplify-add ( expr -- vn/expr/f )
>binary-expr< {
[ 2drop f ]
} cond ; inline
+M: add-expr simplify* simplify-add ;
+M: add-imm-expr simplify* simplify-add ;
+
: simplify-sub ( expr -- vn/expr/f )
>binary-expr< {
{ [ dup expr-zero? ] [ drop ] }
[ 2drop f ]
} cond ; inline
+M: sub-expr simplify* simplify-sub ;
+M: sub-imm-expr simplify* simplify-sub ;
+
: simplify-mul ( expr -- vn/expr/f )
>binary-expr< {
{ [ over expr-one? ] [ drop ] }
[ 2drop f ]
} cond ; inline
+M: mul-expr simplify* simplify-mul ;
+M: mul-imm-expr simplify* simplify-mul ;
+
: simplify-and ( expr -- vn/expr/f )
>binary-expr< {
{ [ 2dup eq? ] [ drop ] }
[ 2drop f ]
} cond ; inline
+M: and-expr simplify* simplify-and ;
+M: and-imm-expr simplify* simplify-and ;
+
: simplify-or ( expr -- vn/expr/f )
>binary-expr< {
{ [ 2dup eq? ] [ drop ] }
[ 2drop f ]
} cond ; inline
+M: or-expr simplify* simplify-or ;
+M: or-imm-expr simplify* simplify-or ;
+
: simplify-xor ( expr -- vn/expr/f )
>binary-expr< {
{ [ over expr-zero? ] [ nip ] }
[ 2drop f ]
} cond ; inline
+M: xor-expr simplify* simplify-xor ;
+M: xor-imm-expr simplify* simplify-xor ;
+
: useless-shr? ( in1 in2 -- ? )
- over op>> \ ##shl-imm eq?
- [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
+ over shl-imm-expr?
+ [ [ src2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
: simplify-shr ( expr -- vn/expr/f )
>binary-expr< {
- { [ 2dup useless-shr? ] [ drop in1>> ] }
+ { [ 2dup useless-shr? ] [ drop src1>> ] }
{ [ dup expr-zero? ] [ drop ] }
[ 2drop f ]
} cond ; inline
+M: shr-expr simplify* simplify-shr ;
+M: shr-imm-expr simplify* simplify-shr ;
+
: simplify-shl ( expr -- vn/expr/f )
>binary-expr< {
{ [ dup expr-zero? ] [ drop ] }
[ 2drop f ]
} cond ; inline
-M: binary-expr simplify*
- dup op>> {
- { \ ##add [ simplify-add ] }
- { \ ##add-imm [ simplify-add ] }
- { \ ##sub [ simplify-sub ] }
- { \ ##sub-imm [ simplify-sub ] }
- { \ ##mul [ simplify-mul ] }
- { \ ##mul-imm [ simplify-mul ] }
- { \ ##and [ simplify-and ] }
- { \ ##and-imm [ simplify-and ] }
- { \ ##or [ simplify-or ] }
- { \ ##or-imm [ simplify-or ] }
- { \ ##xor [ simplify-xor ] }
- { \ ##xor-imm [ simplify-xor ] }
- { \ ##shr [ simplify-shr ] }
- { \ ##shr-imm [ simplify-shr ] }
- { \ ##sar [ simplify-shr ] }
- { \ ##sar-imm [ simplify-shr ] }
- { \ ##shl [ simplify-shl ] }
- { \ ##shl-imm [ simplify-shl ] }
- [ 2drop f ]
- } case ;
+M: shl-expr simplify* simplify-shl ;
+M: shl-imm-expr simplify* simplify-shl ;
M: box-displaced-alien-expr simplify*
[ base>> ] [ displacement>> ] bi {
T{ ##load-reference f 1 + }
T{ ##peek f 2 D 0 }
T{ ##compare f 4 2 1 cc<= }
- T{ ##compare f 6 2 1 cc> }
+ T{ ##compare f 6 2 1 cc/<= }
T{ ##replace f 6 D 0 }
}
] [
T{ ##unbox-float f 10 8 }
T{ ##unbox-float f 11 9 }
T{ ##compare-float f 12 10 11 cc< }
- T{ ##compare-float f 14 10 11 cc>= }
+ T{ ##compare-float f 14 10 11 cc/< }
T{ ##replace f 14 D 0 }
}
] [
sequences.deep
compiler.cfg
compiler.cfg.rpo
+compiler.cfg.def-use
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions
! Local value numbering.
: >copy ( insn -- insn/##copy )
- dup dst>> dup vreg>vn vn>vreg
+ dup defs-vreg dup vreg>vn vn>vreg
2dup eq? [ 2drop ] [ any-rep \ ##copy new-insn nip ] if ;
-: rewrite-loop ( insn -- insn' )
- dup rewrite [ rewrite-loop ] [ ] ?if ;
-
GENERIC: process-instruction ( insn -- insn' )
-M: ##flushable process-instruction
- dup rewrite
- [ process-instruction ]
- [ dup number-values >copy ] ?if ;
-
M: insn process-instruction
dup rewrite
- [ process-instruction ] [ ] ?if ;
+ [ process-instruction ]
+ [ dup defs-vreg [ dup number-values >copy ] when ] ?if ;
M: array process-instruction
[ process-instruction ] map ;
: value-numbering-step ( insns -- insns' )
init-value-graph
- init-expressions
[ process-instruction ] map flatten ;
: value-numbering ( cfg -- cfg' )
combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays alien.complex alien.libraries sets libc
continuations.private fry cpu.architecture classes locals
-source-files.errors
+source-files.errors slots parser generic.parser
compiler.errors
compiler.alien
compiler.constants
: lookup-label ( id -- label )
labels get [ drop <label> ] cache ;
+! Special cases
M: ##no-tco generate-insn drop ;
-M: ##load-immediate generate-insn
- [ dst>> ] [ val>> ] bi %load-immediate ;
-
-M: ##load-reference generate-insn
- [ dst>> ] [ obj>> ] bi %load-reference ;
-
-M: ##peek generate-insn
- [ dst>> ] [ loc>> ] bi %peek ;
-
-M: ##replace generate-insn
- [ src>> ] [ loc>> ] bi %replace ;
-
-M: ##inc-d generate-insn n>> %inc-d ;
-
-M: ##inc-r generate-insn n>> %inc-r ;
-
M: ##call generate-insn
word>> dup sub-primitive>>
[ first % ] [ [ add-call ] [ %call ] bi ] ?if ;
M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
-M: ##return generate-insn drop %return ;
-
-M: _dispatch generate-insn
- [ src>> ] [ temp>> ] bi %dispatch ;
-
M: _dispatch-label generate-insn
label>> lookup-label
cell 0 <repetition> %
rc-absolute-cell label-fixup ;
-: >slot< ( insn -- dst obj slot tag )
- { [ dst>> ] [ obj>> ] [ slot>> ] [ tag>> ] } cleave ; inline
-
-M: ##slot generate-insn
- [ >slot< ] [ temp>> ] bi %slot ;
-
-M: ##slot-imm generate-insn
- >slot< %slot-imm ;
-
-: >set-slot< ( insn -- src obj slot tag )
- { [ src>> ] [ obj>> ] [ slot>> ] [ tag>> ] } cleave ; inline
-
-M: ##set-slot generate-insn
- [ >set-slot< ] [ temp>> ] bi %set-slot ;
-
-M: ##set-slot-imm generate-insn
- >set-slot< %set-slot-imm ;
-
-M: ##string-nth generate-insn
- { [ dst>> ] [ obj>> ] [ index>> ] [ temp>> ] } cleave %string-nth ;
-
-M: ##set-string-nth-fast generate-insn
- { [ src>> ] [ obj>> ] [ index>> ] [ temp>> ] } cleave %set-string-nth-fast ;
-
-: dst/src ( insn -- dst src )
- [ dst>> ] [ src>> ] bi ; inline
-
-: dst/src1/src2 ( insn -- dst src1 src2 )
- [ dst>> ] [ src1>> ] [ src2>> ] tri ; inline
-
-M: ##add generate-insn dst/src1/src2 %add ;
-M: ##add-imm generate-insn dst/src1/src2 %add-imm ;
-M: ##sub generate-insn dst/src1/src2 %sub ;
-M: ##sub-imm generate-insn dst/src1/src2 %sub-imm ;
-M: ##mul generate-insn dst/src1/src2 %mul ;
-M: ##mul-imm generate-insn dst/src1/src2 %mul-imm ;
-M: ##and generate-insn dst/src1/src2 %and ;
-M: ##and-imm generate-insn dst/src1/src2 %and-imm ;
-M: ##or generate-insn dst/src1/src2 %or ;
-M: ##or-imm generate-insn dst/src1/src2 %or-imm ;
-M: ##xor generate-insn dst/src1/src2 %xor ;
-M: ##xor-imm generate-insn dst/src1/src2 %xor-imm ;
-M: ##shl generate-insn dst/src1/src2 %shl ;
-M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
-M: ##shr generate-insn dst/src1/src2 %shr ;
-M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
-M: ##sar generate-insn dst/src1/src2 %sar ;
-M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
-M: ##min generate-insn dst/src1/src2 %min ;
-M: ##max generate-insn dst/src1/src2 %max ;
-M: ##not generate-insn dst/src %not ;
-M: ##log2 generate-insn dst/src %log2 ;
-
-: label/dst/src1/src2 ( insn -- label dst src1 src2 )
- [ label>> lookup-label ] [ dst/src1/src2 ] bi ; inline
-
-M: _fixnum-add generate-insn label/dst/src1/src2 %fixnum-add ;
-M: _fixnum-sub generate-insn label/dst/src1/src2 %fixnum-sub ;
-M: _fixnum-mul generate-insn label/dst/src1/src2 %fixnum-mul ;
-
-: dst/src/temp ( insn -- dst src temp )
- [ dst/src ] [ temp>> ] bi ; inline
-
-M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
-M: ##bignum>integer generate-insn dst/src/temp %bignum>integer ;
-
-M: ##add-float generate-insn dst/src1/src2 %add-float ;
-M: ##sub-float generate-insn dst/src1/src2 %sub-float ;
-M: ##mul-float generate-insn dst/src1/src2 %mul-float ;
-M: ##div-float generate-insn dst/src1/src2 %div-float ;
-M: ##min-float generate-insn dst/src1/src2 %min-float ;
-M: ##max-float generate-insn dst/src1/src2 %max-float ;
-
-M: ##sqrt generate-insn dst/src %sqrt ;
-
-M: ##unary-float-function generate-insn
- [ dst/src ] [ func>> ] bi %unary-float-function ;
-
-M: ##binary-float-function generate-insn
- [ dst/src1/src2 ] [ func>> ] bi %binary-float-function ;
-
-M: ##integer>float generate-insn dst/src %integer>float ;
-M: ##float>integer generate-insn dst/src %float>integer ;
-
-M: ##copy generate-insn [ dst/src ] [ rep>> ] bi %copy ;
-
-M: ##unbox-float generate-insn dst/src %unbox-float ;
-M: ##unbox-any-c-ptr generate-insn dst/src/temp %unbox-any-c-ptr ;
-M: ##box-float generate-insn dst/src/temp %box-float ;
-M: ##box-alien generate-insn dst/src/temp %box-alien ;
-
-M: ##box-displaced-alien generate-insn
- [ dst/src1/src2 ] [ temp1>> ] [ temp2>> ] tri %box-displaced-alien ;
-
-M: ##alien-unsigned-1 generate-insn dst/src %alien-unsigned-1 ;
-M: ##alien-unsigned-2 generate-insn dst/src %alien-unsigned-2 ;
-M: ##alien-unsigned-4 generate-insn dst/src %alien-unsigned-4 ;
-M: ##alien-signed-1 generate-insn dst/src %alien-signed-1 ;
-M: ##alien-signed-2 generate-insn dst/src %alien-signed-2 ;
-M: ##alien-signed-4 generate-insn dst/src %alien-signed-4 ;
-M: ##alien-cell generate-insn dst/src %alien-cell ;
-M: ##alien-float generate-insn dst/src %alien-float ;
-M: ##alien-double generate-insn dst/src %alien-double ;
-
-: >alien-setter< ( insn -- src value )
- [ src>> ] [ value>> ] bi ; inline
-
-M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
-M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
-M: ##set-alien-integer-4 generate-insn >alien-setter< %set-alien-integer-4 ;
-M: ##set-alien-cell generate-insn >alien-setter< %set-alien-cell ;
-M: ##set-alien-float generate-insn >alien-setter< %set-alien-float ;
-M: ##set-alien-double generate-insn >alien-setter< %set-alien-double ;
-
-M: ##allot generate-insn
- {
- [ dst>> ]
- [ size>> ]
- [ class>> ]
- [ temp>> ]
- } cleave
- %allot ;
+M: _prologue generate-insn
+ stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
-M: ##write-barrier generate-insn
- [ src>> ]
- [ card#>> ]
- [ table>> ]
- tri %write-barrier ;
+M: _epilogue generate-insn
+ stack-frame>> total-size>> %epilogue ;
-! GC checks
+M: _spill-area-size generate-insn drop ;
+
+! Some meta-programming to generate simple code generators, where
+! the instruction is unpacked and then a %word is called
+<<
+
+: insn-slot-quot ( spec -- quot )
+ name>> [ reader-word ] [ "label" = ] bi
+ [ \ lookup-label [ ] 2sequence ] [ [ ] 1sequence ] if ;
+
+: codegen-method-body ( class word -- quot )
+ [
+ "insn-slots" word-prop
+ [ insn-slot-quot ] map cleave>quot
+ ] dip suffix ;
+
+SYNTAX: CODEGEN:
+ scan-word [ \ generate-insn create-method-in ] keep scan-word
+ codegen-method-body define ;
+>>
+
+CODEGEN: ##load-immediate %load-immediate
+CODEGEN: ##load-reference %load-reference
+CODEGEN: ##peek %peek
+CODEGEN: ##replace %replace
+CODEGEN: ##inc-d %inc-d
+CODEGEN: ##inc-r %inc-r
+CODEGEN: ##return %return
+CODEGEN: ##slot %slot
+CODEGEN: ##slot-imm %slot-imm
+CODEGEN: ##set-slot %set-slot
+CODEGEN: ##set-slot-imm %set-slot-imm
+CODEGEN: ##string-nth %string-nth
+CODEGEN: ##set-string-nth-fast %set-string-nth-fast
+CODEGEN: ##add %add
+CODEGEN: ##add-imm %add-imm
+CODEGEN: ##sub %sub
+CODEGEN: ##sub-imm %sub-imm
+CODEGEN: ##mul %mul
+CODEGEN: ##mul-imm %mul-imm
+CODEGEN: ##and %and
+CODEGEN: ##and-imm %and-imm
+CODEGEN: ##or %or
+CODEGEN: ##or-imm %or-imm
+CODEGEN: ##xor %xor
+CODEGEN: ##xor-imm %xor-imm
+CODEGEN: ##shl %shl
+CODEGEN: ##shl-imm %shl-imm
+CODEGEN: ##shr %shr
+CODEGEN: ##shr-imm %shr-imm
+CODEGEN: ##sar %sar
+CODEGEN: ##sar-imm %sar-imm
+CODEGEN: ##min %min
+CODEGEN: ##max %max
+CODEGEN: ##not %not
+CODEGEN: ##log2 %log2
+CODEGEN: ##copy %copy
+CODEGEN: ##integer>bignum %integer>bignum
+CODEGEN: ##bignum>integer %bignum>integer
+CODEGEN: ##unbox-float %unbox-float
+CODEGEN: ##box-float %box-float
+CODEGEN: ##add-float %add-float
+CODEGEN: ##sub-float %sub-float
+CODEGEN: ##mul-float %mul-float
+CODEGEN: ##div-float %div-float
+CODEGEN: ##min-float %min-float
+CODEGEN: ##max-float %max-float
+CODEGEN: ##sqrt %sqrt
+CODEGEN: ##unary-float-function %unary-float-function
+CODEGEN: ##binary-float-function %binary-float-function
+CODEGEN: ##single>double-float %single>double-float
+CODEGEN: ##double>single-float %double>single-float
+CODEGEN: ##integer>float %integer>float
+CODEGEN: ##float>integer %float>integer
+CODEGEN: ##unbox-vector %unbox-vector
+CODEGEN: ##broadcast-vector %broadcast-vector
+CODEGEN: ##gather-vector-2 %gather-vector-2
+CODEGEN: ##gather-vector-4 %gather-vector-4
+CODEGEN: ##box-vector %box-vector
+CODEGEN: ##add-vector %add-vector
+CODEGEN: ##sub-vector %sub-vector
+CODEGEN: ##mul-vector %mul-vector
+CODEGEN: ##div-vector %div-vector
+CODEGEN: ##min-vector %min-vector
+CODEGEN: ##max-vector %max-vector
+CODEGEN: ##sqrt-vector %sqrt-vector
+CODEGEN: ##horizontal-add-vector %horizontal-add-vector
+CODEGEN: ##box-alien %box-alien
+CODEGEN: ##box-displaced-alien %box-displaced-alien
+CODEGEN: ##unbox-alien %unbox-alien
+CODEGEN: ##unbox-any-c-ptr %unbox-any-c-ptr
+CODEGEN: ##alien-unsigned-1 %alien-unsigned-1
+CODEGEN: ##alien-unsigned-2 %alien-unsigned-2
+CODEGEN: ##alien-unsigned-4 %alien-unsigned-4
+CODEGEN: ##alien-signed-1 %alien-signed-1
+CODEGEN: ##alien-signed-2 %alien-signed-2
+CODEGEN: ##alien-signed-4 %alien-signed-4
+CODEGEN: ##alien-cell %alien-cell
+CODEGEN: ##alien-float %alien-float
+CODEGEN: ##alien-double %alien-double
+CODEGEN: ##alien-vector %alien-vector
+CODEGEN: ##set-alien-integer-1 %set-alien-integer-1
+CODEGEN: ##set-alien-integer-2 %set-alien-integer-2
+CODEGEN: ##set-alien-integer-4 %set-alien-integer-4
+CODEGEN: ##set-alien-cell %set-alien-cell
+CODEGEN: ##set-alien-float %set-alien-float
+CODEGEN: ##set-alien-double %set-alien-double
+CODEGEN: ##set-alien-vector %set-alien-vector
+CODEGEN: ##allot %allot
+CODEGEN: ##write-barrier %write-barrier
+CODEGEN: ##compare %compare
+CODEGEN: ##compare-imm %compare-imm
+CODEGEN: ##compare-float %compare-float
+
+CODEGEN: _fixnum-add %fixnum-add
+CODEGEN: _fixnum-sub %fixnum-sub
+CODEGEN: _fixnum-mul %fixnum-mul
+CODEGEN: _label resolve-label
+CODEGEN: _branch %jump-label
+CODEGEN: _compare-branch %compare-branch
+CODEGEN: _compare-imm-branch %compare-imm-branch
+CODEGEN: _compare-float-branch %compare-float-branch
+CODEGEN: _dispatch %dispatch
+CODEGEN: _spill %spill
+CODEGEN: _reload %reload
+
+! ##gc
: wipe-locs ( locs temp -- )
'[
_
GENERIC# save-gc-root 1 ( gc-root operand temp -- )
M:: spill-slot save-gc-root ( gc-root operand temp -- )
- temp operand n>> int-rep %reload
+ temp int-rep operand n>> %reload
gc-root temp %save-gc-root ;
M: object save-gc-root drop %save-gc-root ;
M:: spill-slot load-gc-root ( gc-root operand temp -- )
gc-root temp %load-gc-root
- temp operand n>> int-rep %spill ;
+ temp int-rep operand n>> %spill ;
M: object load-gc-root drop %load-gc-root ;
M: int-rep next-fastcall-param
int-regs inc [ ?dummy-stack-params ] [ ?dummy-fp-params ] bi ;
-M: single-float-rep next-fastcall-param
+M: float-rep next-fastcall-param
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
-M: double-float-rep next-fastcall-param
+M: double-rep next-fastcall-param
float-regs inc [ ?dummy-stack-params ] [ ?dummy-int-params ] bi ;
GENERIC: reg-class-full? ( reg-class -- ? )
[ wrap-callback-quot %alien-callback ]
[ alien-return [ %unnest-stacks ] [ %callback-value ] if-void ]
tri ;
-
-M: _prologue generate-insn
- stack-frame>> [ stack-frame set ] [ total-size>> %prologue ] bi ;
-
-M: _epilogue generate-insn
- stack-frame>> total-size>> %epilogue ;
-
-M: _label generate-insn
- id>> lookup-label resolve-label ;
-
-M: _branch generate-insn
- label>> lookup-label %jump-label ;
-
-: >compare< ( insn -- dst temp cc src1 src2 )
- {
- [ dst>> ]
- [ temp>> ]
- [ cc>> ]
- [ src1>> ]
- [ src2>> ]
- } cleave ; inline
-
-M: ##compare generate-insn >compare< %compare ;
-M: ##compare-imm generate-insn >compare< %compare-imm ;
-M: ##compare-float generate-insn >compare< %compare-float ;
-
-: >binary-branch< ( insn -- label cc src1 src2 )
- {
- [ label>> lookup-label ]
- [ cc>> ]
- [ src1>> ]
- [ src2>> ]
- } cleave ; inline
-
-M: _compare-branch generate-insn
- >binary-branch< %compare-branch ;
-
-M: _compare-imm-branch generate-insn
- >binary-branch< %compare-imm-branch ;
-
-M: _compare-float-branch generate-insn
- >binary-branch< %compare-float-branch ;
-
-M: _spill generate-insn
- [ src>> ] [ n>> ] [ rep>> ] tri %spill ;
-
-M: _reload generate-insn
- [ dst>> ] [ n>> ] [ rep>> ] tri %reload ;
-
-M: _spill-area-size generate-insn drop ;
[ 1 "0.169967142900241" ] [ 1.4 [ 1 swap fcos ] compile-call number>string ] unit-test
[ 1 "0.169967142900241" ] [ 1.4 1 [ swap fcos ] compile-call number>string ] unit-test
[ "0.169967142900241" "0.9854497299884601" ] [ 1.4 [ [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
-[ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
\ No newline at end of file
+[ 1 "0.169967142900241" "0.9854497299884601" ] [ 1.4 1 [ swap >float [ fcos ] [ fsin ] bi ] compile-call [ number>string ] bi@ ] unit-test
+
+[ 6.0 ] [ 1.0 [ >float 3.0 + [ B{ 0 0 0 0 } 0 set-alien-float ] [ 2.0 + ] bi ] compile-call ] unit-test
\ No newline at end of file
V{
T{ ##load-reference f 4 1.5 }
T{ ##unbox-float f 1 4 }
- T{ ##copy f 2 1 double-float-rep }
+ T{ ##copy f 2 1 double-rep }
T{ ##box-float f 3 2 }
T{ ##copy f 0 3 int-rep }
} compile-test-bb
[ t ] [ [ 2 '[ _ ] 1 '[ _ + ] compose ] final-info first infer-value (( -- object )) effect= ] unit-test
[ t ] [ [ 2 '[ _ + ] ] final-info first infer-value (( object -- object )) effect= ] unit-test
[ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test
-[ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test
+[ t ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value (( -- object )) effect= ] unit-test
[ f ] [ [ dup drop ] final-info first infer-value ] unit-test
! This should not hang
[ ] [ [ [ dup call( quot -- ) ] dup call( quot -- ) ] final-info drop ] unit-test
-[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test
\ No newline at end of file
+[ ] [ [ [ dup curry call( quot -- ) ] dup curry call( quot -- ) ] final-info drop ] unit-test
+
+! This should get inlined, because the parameter to the curry is literal even though
+! [ boa ] by itself doesn't infer
+TUPLE: a-tuple x ;
+
+[ V{ a-tuple } ] [ [ a-tuple '[ _ boa ] call( x -- tuple ) ] final-classes ] unit-test
\ No newline at end of file
M: compose cached-effect
[ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
+: safe-infer ( quot -- effect )
+ [ infer ] [ 2drop +unknown+ ] recover ;
+
M: quotation cached-effect
dup cached-effect>>
- [ ] [
- [ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
- (>>cached-effect)
- ] ?if ;
+ [ ] [ [ safe-infer dup ] keep (>>cached-effect) ] ?if ;
: call-effect-unsafe? ( quot effect -- ? )
[ cached-effect ] dip
: execute-effect>quot ( effect -- quot )
inline-cache new '[ drop _ _ execute-effect-ic ] ;
+! Some bookkeeping to make sure that crap like
+! [ dup curry call( quot -- ) ] dup curry call( quot -- ) ]
+! doesn't hang the compiler.
+GENERIC: already-inlined-quot? ( quot -- ? )
+
+M: curry already-inlined-quot? quot>> already-inlined-quot? ;
+
+M: compose already-inlined-quot?
+ [ first>> already-inlined-quot? ]
+ [ second>> already-inlined-quot? ] bi or ;
+
+M: quotation already-inlined-quot? already-inlined? ;
+
+GENERIC: add-quot-to-history ( quot -- )
+
+M: curry add-quot-to-history quot>> add-quot-to-history ;
+
+M: compose add-quot-to-history
+ [ first>> add-quot-to-history ]
+ [ second>> add-quot-to-history ] bi ;
+
+M: quotation add-quot-to-history add-to-history ;
+
: last2 ( seq -- penultimate ultimate )
2 tail* first2 ;
(( -- object )) swap compose-effects ;
: (infer-value) ( value-info -- effect )
- dup class>> {
- { \ quotation [
- literal>> [ uninferable ] unless*
- dup already-inlined? [ uninferable ] when
- cached-effect dup +unknown+ = [ uninferable ] when
- ] }
- { \ curry [
- slots>> third (infer-value)
- remove-effect-input
- ] }
- { \ compose [
- slots>> last2 [ (infer-value) ] bi@
- compose-effects
- ] }
- [ uninferable ]
- } case ;
+ dup literal?>> [
+ literal>>
+ [ callable? [ uninferable ] unless ]
+ [ already-inlined-quot? [ uninferable ] when ]
+ [ safe-infer dup +unknown+ = [ uninferable ] when ] tri
+ ] [
+ dup class>> {
+ { \ curry [ slots>> third (infer-value) remove-effect-input ] }
+ { \ compose [ slots>> last2 [ (infer-value) ] bi@ compose-effects ] }
+ [ uninferable ]
+ } case
+ ] if ;
: infer-value ( value-info -- effect/f )
[ (infer-value) ]
recover ;
: (value>quot) ( value-info -- quot )
- dup class>> {
- { \ quotation [ literal>> dup add-to-history '[ drop @ ] ] }
- { \ curry [
- slots>> third (value>quot)
- '[ [ obj>> ] [ quot>> @ ] bi ]
- ] }
- { \ compose [
- slots>> last2 [ (value>quot) ] bi@
- '[ [ first>> @ ] [ second>> @ ] bi ]
- ] }
- } case ;
+ dup literal?>> [
+ literal>> [ add-quot-to-history ] [ '[ drop @ ] ] bi
+ ] [
+ dup class>> {
+ { \ curry [
+ slots>> third (value>quot)
+ '[ [ obj>> ] [ quot>> @ ] bi ]
+ ] }
+ { \ compose [
+ slots>> last2 [ (value>quot) ] bi@
+ '[ [ first>> @ ] [ second>> @ ] bi ]
+ ] }
+ } case
+ ] if ;
: value>quot ( value-info -- quot: ( code effect -- ) )
(value>quot) '[ drop @ ] ;
:: inline-word ( #call word -- ? )
word already-inlined? [ f ] [
#call word splicing-body [
- [
- word add-to-history
- dup (propagate)
- ] with-scope
- #call (>>body) t
+ word add-to-history
+ #call (>>body)
+ #call propagate-body
] [ f ] if*
] if ;
#! Note the logic here: if there's a custom inlining hook,
#! it is permitted to return f, which means that we try the
#! normal inlining heuristic.
- dup custom-inlining? [ 2dup inline-custom ] [ f ] if
- [ 2drop t ] [ (do-inlining) ] if ;
+ [
+ dup custom-inlining? [ 2dup inline-custom ] [ f ] if
+ [ 2drop t ] [ (do-inlining) ] if
+ ] with-scope ;
classes.algebra combinators generic.math splitting fry locals
classes.tuple alien.accessors classes.tuple.private
slots.private definitions strings.private vectors hashtables
-generic quotations
+generic quotations alien
stack-checker.state
compiler.tree.comparisons
compiler.tree.propagation.info
compiler.tree.propagation.simple
compiler.tree.propagation.constraints
compiler.tree.propagation.call-effect
-compiler.tree.propagation.transforms ;
+compiler.tree.propagation.transforms
+compiler.tree.propagation.simd ;
IN: compiler.tree.propagation.known-words
{ + - * / }
'[ 2drop _ ] "outputs" set-word-prop
] each
+\ alien-cell [
+ 2drop simple-alien \ f class-or <class-info>
+] "outputs" set-word-prop
+
{ <tuple> <tuple-boa> } [
[
literal>> dup array? [ first ] [ drop tuple ] if <class-info>
] "outputs" set-word-prop
! the output of clone has the same type as the input
+: cloned-value-info ( value-info -- value-info' )
+ clone f >>literal f >>literal?
+ [ [ dup [ cloned-value-info ] when ] map ] change-slots ;
+
{ clone (clone) } [
- [ clone f >>literal f >>literal? ]
- "outputs" set-word-prop
+ [ cloned-value-info ] "outputs" set-word-prop
] each
\ slot [
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
specialized-arrays.double system sorting math.libm
-math.intervals quotations effects ;
+math.intervals quotations effects alien ;
IN: compiler.tree.propagation.tests
[ V{ } ] [ [ ] final-classes ] unit-test
[ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test
[ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test
+
+! Type function for 'clone' had a subtle issue
+TUPLE: tuple-with-read-only-slot { x read-only } ;
+
+M: tuple-with-read-only-slot clone
+ x>> clone tuple-with-read-only-slot boa ; inline
+
+[ V{ object } ] [
+ [ { 1 2 3 } dup tuple-with-read-only-slot boa clone x>> eq? ] final-classes
+] unit-test
+
+! alien-cell outputs a simple-alien or f
+[ t ] [
+ [ { byte-array fixnum } declare alien-cell dup [ "OOPS" throw ] unless ] final-classes
+ first simple-alien class=
+] unit-test
+
+! Don't crash if bad literal inputs are passed to unsafe words
+[ f ] [ [ { } 1 fixnum+fast ] final-info first literal?>> ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays combinators
+compiler.tree.propagation.info cpu.architecture kernel words math
+math.intervals math.vectors.simd.intrinsics ;
+IN: compiler.tree.propagation.simd
+
+\ (simd-v+) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-v-) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-v*) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-v/) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-vmin) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-vmax) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-vsqrt) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-sum) [
+ nip dup literal?>> [
+ literal>> scalar-rep-of {
+ { float-rep [ float ] }
+ { double-rep [ float ] }
+ } case
+ ] [ drop real ] if
+ <class-info>
+] "outputs" set-word-prop
+
+\ (simd-broadcast) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-gather-2) { byte-array } "default-output-classes" set-word-prop
+
+\ (simd-gather-4) { byte-array } "default-output-classes" set-word-prop
+
+\ assert-positive [
+ real [0,inf] <class/interval-info> value-info-intersect
+] "outputs" set-word-prop
+
+\ alien-vector { byte-array } "default-output-classes" set-word-prop
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors kernel sequences sequences.private assocs words
-namespaces classes.algebra combinators classes classes.tuple
-classes.tuple.private continuations arrays alien.c-types
-math math.private slots generic definitions
-stack-checker.state
+USING: fry accessors kernel sequences sequences.private assocs
+words namespaces classes.algebra combinators
+combinators.short-circuit classes classes.tuple
+classes.tuple.private continuations arrays alien.c-types math
+math.private slots generic definitions stack-checker.state
compiler.tree
compiler.tree.propagation.info
compiler.tree.propagation.nodes
[ in-d>> [ value-info ] map ] [ "outputs" word-prop ] bi*
with-datastack ;
+: literal-inputs? ( #call -- ? )
+ in-d>> [ value-info literal?>> ] all? ;
+
+: input-classes-match? ( #call word -- ? )
+ [ in-d>> ] [ "input-classes" word-prop ] bi*
+ [ [ value-info literal>> ] dip instance? ] 2all? ;
+
: foldable-call? ( #call word -- ? )
- "foldable" word-prop
- [ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
+ {
+ [ nip "foldable" word-prop ]
+ [ drop literal-inputs? ]
+ [ input-classes-match? ]
+ } 2&& ;
: (fold-call) ( #call word -- info )
[ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ _ execute ] ] bi*
USING: alien alien.c-types alien.strings alien.syntax kernel
math sequences namespaces make assocs init accessors
continuations combinators io.encodings.utf8 destructors locals
-arrays specialized-arrays.direct.alien classes.struct
-specialized-arrays.direct.int specialized-arrays.direct.longlong
+arrays specialized-arrays.alien classes.struct
+specialized-arrays.int specialized-arrays.longlong
core-foundation core-foundation.run-loop core-foundation.strings
core-foundation.time ;
IN: core-foundation.fsevents
! Floating point registers can contain data with
! one of these representations
-SINGLETONS: single-float-rep double-float-rep ;
-
-UNION: representation any-rep tagged-rep int-rep single-float-rep double-float-rep ;
+SINGLETONS: float-rep double-rep ;
+
+! On x86, floating point registers are really vector registers
+SINGLETONS:
+float-4-rep
+double-2-rep
+char-16-rep
+uchar-16-rep
+short-8-rep
+ushort-8-rep
+int-4-rep
+uint-4-rep ;
+
+UNION: vector-rep
+float-4-rep
+double-2-rep
+char-16-rep
+uchar-16-rep
+short-8-rep
+ushort-8-rep
+int-4-rep
+uint-4-rep ;
+
+UNION: representation
+any-rep
+tagged-rep
+int-rep
+float-rep
+double-rep
+vector-rep ;
! Register classes
SINGLETONS: int-regs float-regs ;
! A pseudo-register class for parameters spilled on the stack
SINGLETON: stack-params
-: reg-class-of ( rep -- reg-class )
- {
- { tagged-rep [ int-regs ] }
- { int-rep [ int-regs ] }
- { single-float-rep [ float-regs ] }
- { double-float-rep [ float-regs ] }
- { stack-params [ stack-params ] }
- } case ;
-
-: rep-size ( rep -- n )
- {
- { tagged-rep [ cell ] }
- { int-rep [ cell ] }
- { single-float-rep [ 4 ] }
- { double-float-rep [ 8 ] }
- { stack-params [ cell ] }
- } case ;
+GENERIC: reg-class-of ( rep -- reg-class )
+
+M: tagged-rep reg-class-of drop int-regs ;
+M: int-rep reg-class-of drop int-regs ;
+M: float-rep reg-class-of drop float-regs ;
+M: double-rep reg-class-of drop float-regs ;
+M: vector-rep reg-class-of drop float-regs ;
+M: stack-params reg-class-of drop stack-params ;
+
+GENERIC: rep-size ( rep -- n )
+
+M: tagged-rep rep-size drop cell ;
+M: int-rep rep-size drop cell ;
+M: float-rep rep-size drop 4 ;
+M: double-rep rep-size drop 8 ;
+M: stack-params rep-size drop cell ;
+M: vector-rep rep-size drop 16 ;
+
+GENERIC: scalar-rep-of ( rep -- rep' )
+
+M: float-4-rep scalar-rep-of drop float-rep ;
+M: double-2-rep scalar-rep-of drop double-rep ;
! Mapping from register class to machine registers
HOOK: machine-registers cpu ( -- assoc )
HOOK: %not cpu ( dst src -- )
HOOK: %log2 cpu ( dst src -- )
+HOOK: %copy cpu ( dst src rep -- )
+
HOOK: %fixnum-add cpu ( label dst src1 src2 -- )
HOOK: %fixnum-sub cpu ( label dst src1 src2 -- )
HOOK: %fixnum-mul cpu ( label dst src1 src2 -- )
HOOK: %integer>bignum cpu ( dst src temp -- )
HOOK: %bignum>integer cpu ( dst src temp -- )
+HOOK: %unbox-float cpu ( dst src -- )
+HOOK: %box-float cpu ( dst src temp -- )
+
HOOK: %add-float cpu ( dst src1 src2 -- )
HOOK: %sub-float cpu ( dst src1 src2 -- )
HOOK: %mul-float cpu ( dst src1 src2 -- )
HOOK: %unary-float-function cpu ( dst src func -- )
HOOK: %binary-float-function cpu ( dst src1 src2 func -- )
+HOOK: %single>double-float cpu ( dst src -- )
+HOOK: %double>single-float cpu ( dst src -- )
+
HOOK: %integer>float cpu ( dst src -- )
HOOK: %float>integer cpu ( dst src -- )
-HOOK: %copy cpu ( dst src rep -- )
-HOOK: %unbox-float cpu ( dst src -- )
+HOOK: %box-vector cpu ( dst src temp rep -- )
+HOOK: %unbox-vector cpu ( dst src rep -- )
+
+HOOK: %broadcast-vector cpu ( dst src rep -- )
+HOOK: %gather-vector-2 cpu ( dst src1 src2 rep -- )
+HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 rep -- )
+
+HOOK: %add-vector cpu ( dst src1 src2 rep -- )
+HOOK: %sub-vector cpu ( dst src1 src2 rep -- )
+HOOK: %mul-vector cpu ( dst src1 src2 rep -- )
+HOOK: %div-vector cpu ( dst src1 src2 rep -- )
+HOOK: %min-vector cpu ( dst src1 src2 rep -- )
+HOOK: %max-vector cpu ( dst src1 src2 rep -- )
+HOOK: %sqrt-vector cpu ( dst src rep -- )
+HOOK: %horizontal-add-vector cpu ( dst src rep -- )
+
+HOOK: %unbox-alien cpu ( dst src -- )
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
-HOOK: %box-float cpu ( dst src temp -- )
HOOK: %box-alien cpu ( dst src temp -- )
-HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 -- )
+HOOK: %box-displaced-alien cpu ( dst displacement base temp1 temp2 base-class -- )
HOOK: %alien-unsigned-1 cpu ( dst src -- )
HOOK: %alien-unsigned-2 cpu ( dst src -- )
HOOK: %alien-cell cpu ( dst src -- )
HOOK: %alien-float cpu ( dst src -- )
HOOK: %alien-double cpu ( dst src -- )
+HOOK: %alien-vector cpu ( dst src rep -- )
HOOK: %set-alien-integer-1 cpu ( ptr value -- )
HOOK: %set-alien-integer-2 cpu ( ptr value -- )
HOOK: %set-alien-cell cpu ( ptr value -- )
HOOK: %set-alien-float cpu ( ptr value -- )
HOOK: %set-alien-double cpu ( ptr value -- )
+HOOK: %set-alien-vector cpu ( ptr value rep -- )
HOOK: %alien-global cpu ( dst symbol library -- )
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-float-branch cpu ( label cc src1 src2 -- )
-HOOK: %spill cpu ( src n rep -- )
-HOOK: %reload cpu ( dst n rep -- )
+HOOK: %spill cpu ( src rep n -- )
+HOOK: %reload cpu ( dst rep n -- )
HOOK: %loop-entry cpu ( -- )
M: ppc %copy ( dst src rep -- )
{
{ int-rep [ MR ] }
- { double-float-rep [ FMR ] }
+ { double-rep [ FMR ] }
} case ;
M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
"f" resolve-label
] with-scope ;
-M:: ppc %box-displaced-alien ( dst displacement base displacement' base' -- )
+M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
[
"end" define-label
"alloc" define-label
[ [ 1 1 ] dip ADDI ] bi
0 MTLR ;
-:: (%boolean) ( dst temp word -- )
+:: (%boolean) ( dst temp branch1 branch2 -- )
"end" define-label
dst \ f tag-number %load-immediate
- "end" get word execute
+ "end" get branch1 execute( label -- )
+ branch2 [ "end" get branch2 execute( label -- ) ] when
dst \ t %load-reference
"end" get resolve-label ; inline
-: %boolean ( dst temp cc -- )
- negate-cc {
- { cc< [ \ BLT (%boolean) ] }
- { cc<= [ \ BLE (%boolean) ] }
- { cc> [ \ BGT (%boolean) ] }
- { cc>= [ \ BGE (%boolean) ] }
- { cc= [ \ BEQ (%boolean) ] }
- { cc/= [ \ BNE (%boolean) ] }
+:: %boolean ( dst cc temp -- )
+ cc negate-cc order-cc {
+ { cc< [ dst temp \ BLT f (%boolean) ] }
+ { cc<= [ dst temp \ BLE f (%boolean) ] }
+ { cc> [ dst temp \ BGT f (%boolean) ] }
+ { cc>= [ dst temp \ BGE f (%boolean) ] }
+ { cc= [ dst temp \ BEQ f (%boolean) ] }
+ { cc/= [ dst temp \ BNE f (%boolean) ] }
} case ;
: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
: (%compare-imm) ( src1 src2 -- ) [ 0 ] 2dip CMPI ; inline
-: (%compare-float) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
+: (%compare-float-unordered) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
+: (%compare-float-ordered) ( src1 src2 -- ) [ 0 ] dip FCMPO ; inline
+
+:: (%compare-float) ( src1 src2 cc -- branch1 branch2 )
+ cc {
+ { cc< [ src1 src2 (%compare-float-ordered) \ BLT f ] }
+ { cc<= [ src1 src2 (%compare-float-ordered) \ BLT \ BEQ ] }
+ { cc> [ src1 src2 (%compare-float-ordered) \ BGT f ] }
+ { cc>= [ src1 src2 (%compare-float-ordered) \ BGT \ BEQ ] }
+ { cc= [ src1 src2 (%compare-float-unordered) \ BEQ f ] }
+ { cc<> [ src1 src2 (%compare-float-ordered) \ BLT \ BGT ] }
+ { cc<>= [ src1 src2 (%compare-float-ordered) \ BNO f ] }
+ { cc/< [ src1 src2 (%compare-float-unordered) \ BGE f ] }
+ { cc/<= [ src1 src2 (%compare-float-unordered) \ BGT \ BO ] }
+ { cc/> [ src1 src2 (%compare-float-unordered) \ BLE f ] }
+ { cc/>= [ src1 src2 (%compare-float-unordered) \ BLT \ BO ] }
+ { cc/= [ src1 src2 (%compare-float-unordered) \ BNE f ] }
+ { cc/<> [ src1 src2 (%compare-float-unordered) \ BEQ \ BO ] }
+ { cc/<>= [ src1 src2 (%compare-float-unordered) \ BO f ] }
+ } case ; inline
+
+M: ppc %compare [ (%compare) ] 2dip %boolean ;
+
+M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
+
+M:: ppc %compare-float ( dst src1 src2 cc temp -- )
+ cc negate-cc src1 src2 (%compare-float) :> branch2 :> branch1
+ dst temp branch1 branch2 (%boolean) ;
+
+:: %branch ( label cc -- )
+ cc order-cc {
+ { cc< [ label BLT ] }
+ { cc<= [ label BLE ] }
+ { cc> [ label BGT ] }
+ { cc>= [ label BGE ] }
+ { cc= [ label BEQ ] }
+ { cc/= [ label BNE ] }
+ } case ;
-M: ppc %compare (%compare) %boolean ;
-M: ppc %compare-imm (%compare-imm) %boolean ;
-M: ppc %compare-float (%compare-float) %boolean ;
+M: ppc %compare-branch [ (%compare) ] 2dip %branch ;
-: %branch ( label cc -- )
- {
- { cc< [ BLT ] }
- { cc<= [ BLE ] }
- { cc> [ BGT ] }
- { cc>= [ BGE ] }
- { cc= [ BEQ ] }
- { cc/= [ BNE ] }
- } case ;
+M: ppc %compare-imm-branch [ (%compare-imm) ] 2dip %branch ;
-M: ppc %compare-branch (%compare) %branch ;
-M: ppc %compare-imm-branch (%compare-imm) %branch ;
-M: ppc %compare-float-branch (%compare-float) %branch ;
+M:: ppc %compare-float-branch ( label src1 src2 cc -- )
+ cc src1 src2 (%compare-float) :> branch2 :> branch1
+ label branch1 execute( label -- )
+ branch2 [ label branch2 execute( label -- ) ] when ;
: load-from-frame ( dst n rep -- )
{
{ int-rep [ [ 1 ] dip LWZ ] }
- { single-float-rep [ [ 1 ] dip LFS ] }
- { double-float-rep [ [ 1 ] dip LFD ] }
+ { float-rep [ [ 1 ] dip LFS ] }
+ { double-rep [ [ 1 ] dip LFD ] }
{ stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
} case ;
: store-to-frame ( src n rep -- )
{
{ int-rep [ [ 1 ] dip STW ] }
- { single-float-rep [ [ 1 ] dip STFS ] }
- { double-float-rep [ [ 1 ] dip STFD ] }
+ { float-rep [ [ 1 ] dip STFS ] }
+ { double-rep [ [ 1 ] dip STFD ] }
{ stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] }
} case ;
-M: ppc %spill ( src n rep -- )
- [ spill@ ] dip store-to-frame ;
+M: ppc %spill ( src rep n -- )
+ swap [ spill@ ] dip store-to-frame ;
-M: ppc %reload ( dst n rep -- )
- [ spill@ ] dip load-from-frame ;
+M: ppc %reload ( dst rep n -- )
+ swap [ spill@ ] dip load-from-frame ;
M: ppc %loop-entry ;
M: int-rep load-return-reg drop EAX swap next-stack@ MOV ;
M: int-rep store-return-reg drop stack@ EAX MOV ;
-M: single-float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
-M: single-float-rep load-return-reg drop next-stack@ FLDS ;
-M: single-float-rep store-return-reg drop stack@ FSTPS ;
+M: float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
+M: float-rep load-return-reg drop next-stack@ FLDS ;
+M: float-rep store-return-reg drop stack@ FSTPS ;
-M: double-float-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
-M: double-float-rep load-return-reg drop next-stack@ FLDL ;
-M: double-float-rep store-return-reg drop stack@ FSTPL ;
+M: double-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
+M: double-rep load-return-reg drop next-stack@ FLDL ;
+M: double-rep store-return-reg drop stack@ FSTPL ;
: align-sub ( n -- )
[ align-stack ] keep - decr-stack-reg ;
4 "double" c-type (>>align)
] unless
-USING: cpu.x86.features cpu.x86.features.private ;
-
-"-no-sse2" (command-line) member? [
- [ { check_sse2 } compile ] with-optimizer
-
- "Checking if your CPU supports SSE2..." print flush
- sse2? [
- " - yes" print
- enable-sse2
- [
- sse2? [
- "This image was built to use SSE2, which your CPU does not support." print
- "You will need to bootstrap Factor again." print
- flush
- 1 exit
- ] unless
- ] "cpu.x86" add-init-hook
- ] [ " - no" print ] if
-] unless
+USE: vocabs.loader
+
+"cpu.x86.features" require
[ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ;
: float-function-return ( reg -- )
- float-regs return-reg double-float-rep copy-register ;
+ float-regs return-reg double-rep copy-register ;
M:: x86.64 %unary-float-function ( dst src func -- )
0 src float-function-param
! Enable fast calling of libc math functions
enable-float-functions
-! SSE2 is always available on x86-64.
-enable-sse2
-
USE: vocabs.loader
{
{ [ os unix? ] [ "cpu.x86.64.unix" require ] }
{ [ os winnt? ] [ "cpu.x86.64.winnt" require ] }
} cond
+
+"cpu.x86.features" require
: MOVHPD ( dest src -- ) HEX: 16 HEX: 66 2-operand-sse ;
: MOVSHDUP ( dest src -- ) HEX: 16 HEX: f3 2-operand-rm-sse ;
+ALIAS: MOVHLPS MOVLPS
+ALIAS: MOVLHPS MOVHPS
+
: PREFETCHNTA ( mem -- ) { BIN: 000 f { HEX: 0f HEX: 18 } } 1-operand ;
: PREFETCHT0 ( mem -- ) { BIN: 001 f { HEX: 0f HEX: 18 } } 1-operand ;
: PREFETCHT1 ( mem -- ) { BIN: 010 f { HEX: 0f HEX: 18 } } 1-operand ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel math alien.syntax ;
+USING: system kernel math alien.syntax combinators locals init io
+cpu.x86 compiler compiler.units accessors ;
IN: cpu.x86.features
<PRIVATE
-FUNCTION: bool check_sse2 ( ) ;
+FUNCTION: int sse_version ( ) ;
FUNCTION: longlong read_timestamp_counter ( ) ;
PRIVATE>
-HOOK: sse2? cpu ( -- ? )
+ALIAS: sse-version sse_version
-M: x86.32 sse2? check_sse2 ;
-
-M: x86.64 sse2? t ;
+: sse-string ( version -- string )
+ {
+ { 00 [ "no SSE" ] }
+ { 10 [ "SSE1" ] }
+ { 20 [ "SSE2" ] }
+ { 30 [ "SSE3" ] }
+ { 33 [ "SSSE3" ] }
+ { 41 [ "SSE4.1" ] }
+ { 42 [ "SSE4.2" ] }
+ } case ;
HOOK: instruction-count cpu ( -- n )
: count-instructions ( quot -- n )
instruction-count [ call ] dip instruction-count swap - ; inline
+
+USING: cpu.x86.features cpu.x86.features.private ;
+
+:: install-sse-check ( version -- )
+ [
+ sse-version version < [
+ "This image was built to use " write
+ version sse-string write
+ " but your CPU supports " write
+ sse-version sse-string write "." print
+ "You will need to bootstrap Factor again." print
+ flush
+ 1 exit
+ ] when
+ ] "cpu.x86" add-init-hook ;
+
+: enable-sse ( version -- )
+ {
+ { 00 [ ] }
+ { 10 [ ] }
+ { 20 [ enable-sse2 ] }
+ { 30 [ enable-sse3 ] }
+ { 33 [ enable-sse3 ] }
+ { 41 [ enable-sse3 ] }
+ { 42 [ enable-sse3 ] }
+ } case ;
+
+[ { sse_version } compile ] with-optimizer
+
+"Checking for multimedia extensions: " write sse-version
+[ sse-string write " detected" print ]
+[ install-sse-check ]
+[ enable-sse ] tri
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs alien alien.c-types arrays strings
cpu.x86.assembler cpu.x86.assembler.private cpu.x86.assembler.operands
cpu.architecture kernel kernel.private math memory namespaces make
sequences words system layouts combinators math.order fry locals
-compiler.constants
+compiler.constants byte-arrays
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.intrinsics
M: x86 %not drop NOT ;
M: x86 %log2 BSR ;
+GENERIC: copy-register* ( dst src rep -- )
+
+M: int-rep copy-register* drop MOV ;
+M: tagged-rep copy-register* drop MOV ;
+M: float-rep copy-register* drop MOVSS ;
+M: double-rep copy-register* drop MOVSD ;
+M: float-4-rep copy-register* drop MOVUPS ;
+M: double-2-rep copy-register* drop MOVUPD ;
+M: vector-rep copy-register* drop MOVDQU ;
+
+: copy-register ( dst src rep -- )
+ 2over eq? [ 3drop ] [ copy-register* ] if ;
+
+M: x86 %copy ( dst src rep -- ) copy-register ;
+
:: overflow-template ( label dst src1 src2 insn -- )
src1 src2 insn call
label JO ; inline
M: x86 %max-float nip MAXSD ;
M: x86 %sqrt SQRTSD ;
+M: x86 %single>double-float CVTSS2SD ;
+M: x86 %double>single-float CVTSD2SS ;
+
M: x86 %integer>float CVTSI2SD ;
M: x86 %float>integer CVTTSD2SI ;
-GENERIC: copy-register* ( dst src rep -- )
+M: x86 %unbox-float ( dst src -- )
+ float-offset [+] MOVSD ;
-M: int-rep copy-register* drop MOV ;
-M: tagged-rep copy-register* drop MOV ;
-M: single-float-rep copy-register* drop MOVSS ;
-M: double-float-rep copy-register* drop MOVSD ;
+M:: x86 %box-float ( dst src temp -- )
+ dst 16 float temp %allot
+ dst float-offset [+] src MOVSD ;
-: copy-register ( dst src rep -- )
- 2over eq? [ 3drop ] [ copy-register* ] if ;
+M:: x86 %box-vector ( dst src rep temp -- )
+ dst rep rep-size 2 cells + byte-array temp %allot
+ 16 tag-fixnum dst 1 byte-array tag-number %set-slot-imm
+ dst byte-array-offset [+]
+ src rep copy-register ;
-M: x86 %copy ( dst src rep -- ) copy-register ;
+M:: x86 %unbox-vector ( dst src rep -- )
+ dst src byte-array-offset [+]
+ rep copy-register ;
-M: x86 %unbox-float ( dst src -- )
- float-offset [+] MOVSD ;
+M: x86 %broadcast-vector ( dst src rep -- )
+ {
+ { float-4-rep [ [ MOVAPS ] [ drop dup 0 SHUFPS ] 2bi ] }
+ { double-2-rep [ [ MOVAPD ] [ drop dup 0 SHUFPD ] 2bi ] }
+ } case ;
+
+M:: x86 %gather-vector-4 ( dst src1 src2 src3 src4 rep -- )
+ rep {
+ {
+ float-4-rep
+ [
+ dst src1 MOVSS
+ dst src2 UNPCKLPS
+ src3 src4 UNPCKLPS
+ dst src3 HEX: 44 SHUFPS
+ ]
+ }
+ } case ;
+
+M:: x86 %gather-vector-2 ( dst src1 src2 rep -- )
+ rep {
+ {
+ double-2-rep
+ [
+ dst src1 MOVAPD
+ dst src2 0 SHUFPD
+ ]
+ }
+ } case ;
+
+M: x86 %add-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ ADDPS ] }
+ { double-2-rep [ ADDPD ] }
+ { char-16-rep [ PADDB ] }
+ { uchar-16-rep [ PADDB ] }
+ { short-8-rep [ PADDW ] }
+ { ushort-8-rep [ PADDW ] }
+ { int-4-rep [ PADDD ] }
+ { uint-4-rep [ PADDD ] }
+ } case drop ;
+
+M: x86 %sub-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ SUBPS ] }
+ { double-2-rep [ SUBPD ] }
+ { char-16-rep [ PSUBB ] }
+ { uchar-16-rep [ PSUBB ] }
+ { short-8-rep [ PSUBW ] }
+ { ushort-8-rep [ PSUBW ] }
+ { int-4-rep [ PSUBD ] }
+ { uint-4-rep [ PSUBD ] }
+ } case drop ;
+
+M: x86 %mul-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ MULPS ] }
+ { double-2-rep [ MULPD ] }
+ { int-4-rep [ PMULLW ] }
+ } case drop ;
+
+M: x86 %div-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ DIVPS ] }
+ { double-2-rep [ DIVPD ] }
+ } case drop ;
+
+M: x86 %min-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ MINPS ] }
+ { double-2-rep [ MINPD ] }
+ } case drop ;
+
+M: x86 %max-vector ( dst src1 src2 rep -- )
+ {
+ { float-4-rep [ MAXPS ] }
+ { double-2-rep [ MAXPD ] }
+ } case drop ;
+
+M: x86 %sqrt-vector ( dst src rep -- )
+ {
+ { float-4-rep [ SQRTPS ] }
+ { double-2-rep [ SQRTPD ] }
+ } case ;
+
+M: x86 %horizontal-add-vector ( dst src rep -- )
+ {
+ { float-4-rep [ [ MOVAPS ] [ HADDPS ] [ HADDPS ] 2tri ] }
+ { double-2-rep [ [ MOVAPD ] [ HADDPD ] 2bi ] }
+ } case ;
+
+M: x86 %unbox-alien ( dst src -- )
+ alien-offset [+] MOV ;
M:: x86 %unbox-any-c-ptr ( dst src temp -- )
[
"end" resolve-label
] with-scope ;
-M:: x86 %box-float ( dst src temp -- )
- dst 16 float temp %allot
- dst float-offset [+] src MOVSD ;
-
: alien@ ( reg n -- op ) cells alien tag-number - [+] ;
:: %allot-alien ( dst displacement base temp -- )
"end" resolve-label
] with-scope ;
-M:: x86 %box-displaced-alien ( dst displacement base displacement' base' -- )
+M:: x86 %box-displaced-alien ( dst displacement base displacement' base' base-class -- )
[
"end" define-label
"ok" define-label
M: x86 %alien-signed-4 32 %alien-signed-getter ;
M: x86 %alien-cell [] MOV ;
-M: x86 %alien-float dupd [] MOVSS dup CVTSS2SD ;
+M: x86 %alien-float [] MOVSS ;
M: x86 %alien-double [] MOVSD ;
+M: x86 %alien-vector [ [] ] dip copy-register ;
:: %alien-integer-setter ( ptr value size -- )
value { ptr } size [| new-value |
M: x86 %set-alien-integer-2 16 %alien-integer-setter ;
M: x86 %set-alien-integer-4 32 %alien-integer-setter ;
M: x86 %set-alien-cell [ [] ] dip MOV ;
-M: x86 %set-alien-float dup dup CVTSD2SS [ [] ] dip MOVSS ;
+M: x86 %set-alien-float [ [] ] dip MOVSS ;
M: x86 %set-alien-double [ [] ] dip MOVSD ;
+M: x86 %set-alien-vector [ [] ] 2dip copy-register ;
: shift-count? ( reg -- ? ) { ECX RCX } memq? ;
temp 0 MOV \ t rc-absolute-cell rel-immediate
dst temp word execute ; inline
-M: x86 %compare ( dst temp cc src1 src2 -- )
- CMP {
- { cc< [ \ CMOVL %boolean ] }
- { cc<= [ \ CMOVLE %boolean ] }
- { cc> [ \ CMOVG %boolean ] }
- { cc>= [ \ CMOVGE %boolean ] }
- { cc= [ \ CMOVE %boolean ] }
- { cc/= [ \ CMOVNE %boolean ] }
+M:: x86 %compare ( dst src1 src2 cc temp -- )
+ src1 src2 CMP
+ cc order-cc {
+ { cc< [ dst temp \ CMOVL %boolean ] }
+ { cc<= [ dst temp \ CMOVLE %boolean ] }
+ { cc> [ dst temp \ CMOVG %boolean ] }
+ { cc>= [ dst temp \ CMOVGE %boolean ] }
+ { cc= [ dst temp \ CMOVE %boolean ] }
+ { cc/= [ dst temp \ CMOVNE %boolean ] }
} case ;
-M: x86 %compare-imm ( dst temp cc src1 src2 -- )
+M: x86 %compare-imm ( dst src1 src2 cc temp -- )
%compare ;
-M: x86 %compare-float ( dst temp cc src1 src2 -- )
- UCOMISD {
- { cc< [ \ CMOVB %boolean ] }
- { cc<= [ \ CMOVBE %boolean ] }
- { cc> [ \ CMOVA %boolean ] }
- { cc>= [ \ CMOVAE %boolean ] }
- { cc= [ \ CMOVE %boolean ] }
- { cc/= [ \ CMOVNE %boolean ] }
+: %cmov-float= ( dst src -- )
+ [
+ "no-move" define-label
+
+ "no-move" get [ JNE ] [ JP ] bi
+ MOV
+ "no-move" resolve-label
+ ] with-scope ;
+
+: %cmov-float/= ( dst src -- )
+ [
+ "no-move" define-label
+ "move" define-label
+
+ "move" get JP
+ "no-move" get JE
+ "move" resolve-label
+ MOV
+ "no-move" resolve-label
+ ] with-scope ;
+
+M:: x86 %compare-float ( dst src1 src2 cc temp -- )
+ cc {
+ { cc< [ src2 src1 COMISD dst temp \ CMOVA %boolean ] }
+ { cc<= [ src2 src1 COMISD dst temp \ CMOVAE %boolean ] }
+ { cc> [ src1 src2 COMISD dst temp \ CMOVA %boolean ] }
+ { cc>= [ src1 src2 COMISD dst temp \ CMOVAE %boolean ] }
+ { cc= [ src1 src2 UCOMISD dst temp \ %cmov-float= %boolean ] }
+ { cc<> [ src1 src2 COMISD dst temp \ CMOVNE %boolean ] }
+ { cc<>= [ src1 src2 COMISD dst temp \ CMOVNP %boolean ] }
+ { cc/< [ src2 src1 UCOMISD dst temp \ CMOVBE %boolean ] }
+ { cc/<= [ src2 src1 UCOMISD dst temp \ CMOVB %boolean ] }
+ { cc/> [ src1 src2 UCOMISD dst temp \ CMOVBE %boolean ] }
+ { cc/>= [ src1 src2 UCOMISD dst temp \ CMOVB %boolean ] }
+ { cc/= [ src1 src2 UCOMISD dst temp \ %cmov-float/= %boolean ] }
+ { cc/<> [ src1 src2 UCOMISD dst temp \ CMOVE %boolean ] }
+ { cc/<>= [ src1 src2 UCOMISD dst temp \ CMOVP %boolean ] }
} case ;
-M: x86 %compare-branch ( label cc src1 src2 -- )
- CMP {
- { cc< [ JL ] }
- { cc<= [ JLE ] }
- { cc> [ JG ] }
- { cc>= [ JGE ] }
- { cc= [ JE ] }
- { cc/= [ JNE ] }
+M:: x86 %compare-branch ( label src1 src2 cc -- )
+ src1 src2 CMP
+ cc order-cc {
+ { cc< [ label JL ] }
+ { cc<= [ label JLE ] }
+ { cc> [ label JG ] }
+ { cc>= [ label JGE ] }
+ { cc= [ label JE ] }
+ { cc/= [ label JNE ] }
} case ;
M: x86 %compare-imm-branch ( label src1 src2 cc -- )
%compare-branch ;
-M: x86 %compare-float-branch ( label cc src1 src2 -- )
- UCOMISD {
- { cc< [ JB ] }
- { cc<= [ JBE ] }
- { cc> [ JA ] }
- { cc>= [ JAE ] }
- { cc= [ JE ] }
- { cc/= [ JNE ] }
+: %jump-float= ( label -- )
+ [
+ "no-jump" define-label
+ "no-jump" get JP
+ JE
+ "no-jump" resolve-label
+ ] with-scope ;
+
+: %jump-float/= ( label -- )
+ [ JNE ] [ JP ] bi ;
+
+M:: x86 %compare-float-branch ( label src1 src2 cc -- )
+ cc {
+ { cc< [ src2 src1 COMISD label JA ] }
+ { cc<= [ src2 src1 COMISD label JAE ] }
+ { cc> [ src1 src2 COMISD label JA ] }
+ { cc>= [ src1 src2 COMISD label JAE ] }
+ { cc= [ src1 src2 UCOMISD label %jump-float= ] }
+ { cc<> [ src1 src2 COMISD label JNE ] }
+ { cc<>= [ src1 src2 COMISD label JNP ] }
+ { cc/< [ src2 src1 UCOMISD label JBE ] }
+ { cc/<= [ src2 src1 UCOMISD label JB ] }
+ { cc/> [ src1 src2 UCOMISD label JBE ] }
+ { cc/>= [ src1 src2 UCOMISD label JB ] }
+ { cc/= [ src1 src2 UCOMISD label %jump-float/= ] }
+ { cc/<> [ src1 src2 UCOMISD label JE ] }
+ { cc/<>= [ src1 src2 UCOMISD label JP ] }
} case ;
-M: x86 %spill ( src n rep -- ) [ spill@ swap ] dip copy-register ;
-M: x86 %reload ( dst n rep -- ) [ spill@ ] dip copy-register ;
+M:: x86 %spill ( src rep n -- )
+ n spill@ src rep copy-register ;
+
+M:: x86 %reload ( dst rep n -- )
+ dst n spill@ rep copy-register ;
M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
: enable-sse2 ( -- )
enable-float-intrinsics
enable-fsqrt
- enable-float-min/max ;
+ enable-float-min/max
+ enable-sse2-simd ;
+
+: enable-sse3 ( -- )
+ enable-sse2
+ enable-sse3-simd ;
enable-min/max
io.encodings io ;
IN: environment.winnt
-<< "TCHAR" require-c-arrays >>
+<< "TCHAR" require-c-array >>
M: winnt os-env ( key -- value )
MAX_UNICODE_PATH "TCHAR" <c-array>
SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ;
+SYNTAX: DEFINES-PRIVATE [ begin-private create-in end-private ] (INTERPOLATE) ;
+
SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;
DEFER: ;FUNCTOR delimiter
io.streams.c io.streams.null libc kernel math namespaces sequences
threads windows windows.errors windows.kernel32 strings splitting
ascii system accessors locals classes.struct combinators.short-circuit ;
-QUALIFIED: windows.winsock
IN: io.backend.windows.nt
! Global variable with assoc mapping overlapped to threads
C: <io-callback> io-callback
: (make-overlapped) ( -- overlapped-ext )
- "OVERLAPPED" malloc-object &free ;
+ OVERLAPPED malloc-struct &free ;
: make-overlapped ( port -- overlapped-ext )
[ (make-overlapped) ] dip
- handle>> ptr>> [ over set-OVERLAPPED-offset ] when* ;
+ handle>> ptr>> [ >>offset ] when* ;
M: winnt FileArgs-overlapped ( port -- overlapped )
make-overlapped ;
: twiddle-thumbs ( overlapped port -- bytes-transferred )
[
drop
- [ pending-overlapped get-global set-at ] curry "I/O" suspend
+ [ >c-ptr pending-overlapped get-global set-at ] curry "I/O" suspend
{
{ [ dup integer? ] [ ] }
{ [ dup array? ] [
f <void*> [ ! overlapped
us [ 1000 /i ] [ INFINITE ] if* ! timeout
GetQueuedCompletionStatus zero?
- ] keep *void*
+ ] keep
+ *void* dup [ OVERLAPPED memory>struct ] when
] keep *int spin ;
: resume-callback ( result overlapped -- )
- pending-overlapped get-global delete-at* drop resume-with ;
+ >c-ptr pending-overlapped get-global delete-at* drop resume-with ;
: handle-overlapped ( us -- ? )
wait-for-overlapped [
M: winnt init-io ( -- )
<master-completion-port> master-completion-port set-global
- H{ } clone pending-overlapped set-global
- windows.winsock:init-winsock ;
+ H{ } clone pending-overlapped set-global ;
ERROR: invalid-file-size n ;
\r
: make-token-privileges ( name ? -- obj )\r
"TOKEN_PRIVILEGES" <c-object>\r
- 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep\r
- "LUID_AND_ATTRIBUTES" malloc-array &free\r
+ 1 over set-TOKEN_PRIVILEGES-PrivilegeCount\r
+ "LUID_AND_ATTRIBUTES" malloc-object &free\r
over set-TOKEN_PRIVILEGES-Privileges\r
\r
swap [\r
USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.ports io.binary io.timeouts system
strings kernel math namespaces sequences windows.errors
-windows.kernel32 windows.shell32 windows.types windows.winsock
-splitting continuations math.bitwise accessors init sets assocs
+windows.kernel32 windows.shell32 windows.types splitting
+continuations math.bitwise accessors init sets assocs
classes.struct classes ;
IN: io.backend.windows
: default-security-attributes ( -- obj )
SECURITY_ATTRIBUTES <struct>
- dup class heap-size >>nLength ;
+ SECURITY_ATTRIBUTES heap-size >>nLength ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.strings combinators
grouping io.encodings.utf8 io.files kernel math sequences
-system unix io.files.unix specialized-arrays.direct.uint arrays
+system unix io.files.unix specialized-arrays.uint arrays
unix.statfs.macosx unix.statvfs.macosx unix.getfsstat.macosx
io.files.info.unix io.files.info classes.struct struct-arrays ;
IN: io.files.info.unix.macosx
console-vm "-run=listener" 2array >>command
+closed+ >>stdin
+stdout+ >>stderr
- ascii [ contents ] with-process-reader
+ ascii [ lines last ] with-process-reader
] unit-test
: launcher-test-path ( -- str )
[ "( scratchpad ) " ] [
console-vm "-run=listener" 2array
- ascii [ "USE: system 0 exit" print flush readln ] with-process-stream
+ ascii [ "USE: system 0 exit" print flush lines last ] with-process-stream
] unit-test
[ ] [
-USING: io.mmap.functor specialized-arrays.direct.alien ;
+USING: io.mmap.functor specialized-arrays.alien ;
IN: io.mmap.alien
<< "void*" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.bool ;
+USING: io.mmap.functor specialized-arrays.bool ;
IN: io.mmap.bool
<< "bool" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.char ;
+USING: io.mmap.functor specialized-arrays.char ;
IN: io.mmap.char
<< "char" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.double ;
+USING: io.mmap.functor specialized-arrays.double ;
IN: io.mmap.double
<< "double" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.float ;
+USING: io.mmap.functor specialized-arrays.float ;
IN: io.mmap.float
<< "float" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.int ;
+USING: io.mmap.functor specialized-arrays.int ;
IN: io.mmap.int
<< "int" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.long ;
+USING: io.mmap.functor specialized-arrays.long ;
IN: io.mmap.long
<< "long" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.longlong ;
+USING: io.mmap.functor specialized-arrays.longlong ;
IN: io.mmap.longlong
<< "longlong" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.short ;
+USING: io.mmap.functor specialized-arrays.short ;
IN: io.mmap.short
<< "short" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.uchar ;
+USING: io.mmap.functor specialized-arrays.uchar ;
IN: io.mmap.uchar
<< "uchar" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.uint ;
+USING: io.mmap.functor specialized-arrays.uint ;
IN: io.mmap.uint
<< "uint" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.ulong ;
+USING: io.mmap.functor specialized-arrays.ulong ;
IN: io.mmap.ulong
<< "ulong" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.ulonglong ;
+USING: io.mmap.functor specialized-arrays.ulonglong ;
IN: io.mmap.ulonglong
<< "ulonglong" define-mapped-array >>
\ No newline at end of file
-USING: io.mmap.functor specialized-arrays.direct.ushort ;
+USING: io.mmap.functor specialized-arrays.ushort ;
IN: io.mmap.ushort
<< "ushort" define-mapped-array >>
\ No newline at end of file
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces continuations
-destructors io debugger io.sockets sequences summary calendar
-delegate system vocabs.loader combinators present ;
+USING: accessors kernel namespaces continuations destructors io
+debugger io.sockets io.sockets.private sequences summary
+calendar delegate system vocabs.loader combinators present ;
IN: io.sockets.secure
SYMBOL: secure-socket-timeout
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors unix byte-arrays kernel sequences
-namespaces math math.order combinators init alien alien.c-types
+USING: accessors unix byte-arrays kernel sequences namespaces
+math math.order combinators init alien alien.c-types
alien.strings libc continuations destructors openssl
openssl.libcrypto openssl.libssl io io.files io.ports
io.backend.unix io.sockets.unix io.encodings.ascii io.buffers
-io.sockets io.sockets.secure io.sockets.secure.openssl
-io.timeouts system summary fry ;
+io.sockets io.sockets.private io.sockets.secure
+io.sockets.secure.openssl io.timeouts system summary fry ;
FROM: io.ports => shutdown ;
IN: io.sockets.secure.unix
IN: io.sockets.tests
-USING: io.sockets sequences math tools.test namespaces accessors
-kernel destructors calendar io.timeouts io.encodings.utf8 io
-concurrency.promises threads io.streams.string ;
+USING: io.sockets io.sockets.private sequences math tools.test
+namespaces accessors kernel destructors calendar io.timeouts
+io.encodings.utf8 io concurrency.promises threads
+io.streams.string ;
[ B{ 1 2 3 4 } ]
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
arrays io.encodings io.ports io.streams.duplex io.encodings.ascii
alien.strings io.binary accessors destructors classes byte-arrays
parser alien.c-types math.parser splitting grouping math assocs
-summary system vocabs.loader combinators present fry vocabs.parser ;
+summary system vocabs.loader combinators present fry vocabs.parser
+classes.struct ;
IN: io.sockets
<< {
} cond use-vocab >>
! Addressing
+<PRIVATE
+
GENERIC: protocol-family ( addrspec -- af )
GENERIC: sockaddr-size ( addrspec -- n )
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
-TUPLE: local path ;
+HOOK: sockaddr-of-family os ( alien af -- sockaddr )
-: <local> ( path -- addrspec )
- normalize-path local boa ;
+HOOK: addrspec-of-family os ( af -- addrspec )
-M: local present path>> "Unix domain socket: " prepend ;
+PRIVATE>
TUPLE: abstract-inet host port ;
M: abstract-inet present
[ host>> ":" ] [ port>> number>string ] bi 3append ;
+TUPLE: local path ;
+
+: <local> ( path -- addrspec )
+ normalize-path local boa ;
+
+M: local present path>> "Unix domain socket: " prepend ;
+
TUPLE: inet4 < abstract-inet ;
C: <inet4> inet4
M: inet4 protocol-family drop PF_INET ;
-M: inet4 sockaddr-size drop "sockaddr-in" heap-size ;
+M: inet4 sockaddr-size drop sockaddr-in heap-size ;
-M: inet4 empty-sockaddr drop "sockaddr-in" <c-object> ;
+M: inet4 empty-sockaddr drop sockaddr-in <struct> ;
M: inet4 make-sockaddr ( inet -- sockaddr )
- "sockaddr-in" <c-object>
- AF_INET over set-sockaddr-in-family
- over port>> htons over set-sockaddr-in-port
- over host>>
- "0.0.0.0" or
- rot inet-pton *uint over set-sockaddr-in-addr ;
+ sockaddr-in <struct>
+ AF_INET >>family
+ swap [ port>> htons >>port ]
+ [ host>> "0.0.0.0" or ]
+ [ inet-pton *uint >>addr ] tri ;
-M: inet4 parse-sockaddr
- [ dup sockaddr-in-addr <uint> ] dip inet-ntop
- swap sockaddr-in-port ntohs <inet4> ;
+M: inet4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
+ [ [ addr>> <uint> ] dip inet-ntop ]
+ [ drop port>> ntohs ] 2bi <inet4> ;
TUPLE: inet6 < abstract-inet ;
M: inet6 protocol-family drop PF_INET6 ;
-M: inet6 sockaddr-size drop "sockaddr-in6" heap-size ;
+M: inet6 sockaddr-size drop sockaddr-in6 heap-size ;
-M: inet6 empty-sockaddr drop "sockaddr-in6" <c-object> ;
+M: inet6 empty-sockaddr drop sockaddr-in6 <struct> ;
M: inet6 make-sockaddr ( inet -- sockaddr )
- "sockaddr-in6" <c-object>
- AF_INET6 over set-sockaddr-in6-family
- over port>> htons over set-sockaddr-in6-port
- over host>> "::" or
- rot inet-pton over set-sockaddr-in6-addr ;
+ sockaddr-in6 <struct>
+ AF_INET6 >>family
+ swap [ port>> htons >>port ]
+ [ host>> "::" or ]
+ [ inet-pton >>addr ] tri ;
M: inet6 parse-sockaddr
- [ dup sockaddr-in6-addr ] dip inet-ntop
- swap sockaddr-in6-port ntohs <inet6> ;
-
-: addrspec-of-family ( af -- addrspec )
- {
- { AF_INET [ T{ inet4 } ] }
- { AF_INET6 [ T{ inet6 } ] }
- { AF_UNIX [ T{ local } ] }
- [ drop f ]
- } case ;
+ [ [ addr>> ] dip inet-ntop ]
+ [ drop port>> ntohs ] 2bi <inet6> ;
M: f parse-sockaddr nip ;
+<PRIVATE
+
GENERIC: (get-local-address) ( handle remote -- sockaddr )
: get-local-address ( handle remote -- local )
2bi
] with-destructors ;
+TUPLE: server-port < port addr encoding ;
+
+: check-server-port ( port -- port )
+ dup check-disposed
+ dup server-port? [ "Not a server port" throw ] unless ; inline
+
+GENERIC: (server) ( addrspec -- handle )
+
+GENERIC: (accept) ( server addrspec -- handle sockaddr )
+
+TUPLE: datagram-port < port addr ;
+
+HOOK: (datagram) io-backend ( addr -- datagram )
+
+: check-datagram-port ( port -- port )
+ dup check-disposed
+ dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
+
+HOOK: (receive) io-backend ( datagram -- packet addrspec )
+
+: check-datagram-send ( packet addrspec port -- packet addrspec port )
+ check-datagram-port
+ 2dup addr>> [ class ] bi@ assert=
+ pick class byte-array assert= ;
+
+HOOK: (send) io-backend ( packet addrspec datagram -- )
+
+: addrinfo>addrspec ( addrinfo -- addrspec )
+ [ [ addr>> ] [ family>> ] bi sockaddr-of-family ]
+ [ family>> addrspec-of-family ] bi
+ parse-sockaddr ;
+
+: parse-addrinfo-list ( addrinfo -- seq )
+ [ next>> dup [ addrinfo memory>struct ] when ] follow
+ [ addrinfo>addrspec ] map
+ sift ;
+
+HOOK: addrinfo-error io-backend ( n -- )
+
+: resolve-passive-host ( -- addrspecs )
+ { T{ inet6 f "::" f } T{ inet4 f "0.0.0.0" f } } [ clone ] map ;
+
+: prepare-addrinfo ( -- addrinfo )
+ addrinfo <struct>
+ PF_UNSPEC >>family
+ IPPROTO_TCP >>protocol ;
+
+: fill-in-ports ( addrspecs port -- addrspecs )
+ '[ _ >>port ] map ;
+
+PRIVATE>
+
: <client> ( remote encoding -- stream local )
[ (client) ] dip swap [ <encoder-duplex> ] dip ;
] dip with-stream
] with-scope ; inline
-TUPLE: server-port < port addr encoding ;
-
-: check-server-port ( port -- port )
- dup check-disposed
- dup server-port? [ "Not a server port" throw ] unless ; inline
-
-GENERIC: (server) ( addrspec -- handle )
-
: <server> ( addrspec encoding -- server )
[
[ (server) ] keep
>>addr
] dip >>encoding ;
-GENERIC: (accept) ( server addrspec -- handle sockaddr )
-
: accept ( server -- client remote )
[
dup addr>>
<ports>
] keep encoding>> <encoder-duplex> swap ;
-TUPLE: datagram-port < port addr ;
-
-HOOK: (datagram) io-backend ( addr -- datagram )
-
: <datagram> ( addrspec -- datagram )
[
[ (datagram) |dispose ] keep
>>addr
] with-destructors ;
-: check-datagram-port ( port -- port )
- dup check-disposed
- dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
-
-HOOK: (receive) io-backend ( datagram -- packet addrspec )
-
: receive ( datagram -- packet addrspec )
check-datagram-port
[ (receive) ] [ addr>> ] bi parse-sockaddr ;
-: check-datagram-send ( packet addrspec port -- packet addrspec port )
- check-datagram-port
- 2dup addr>> [ class ] bi@ assert=
- pick class byte-array assert= ;
-
-HOOK: (send) io-backend ( packet addrspec datagram -- )
-
: send ( packet addrspec datagram -- )
check-datagram-send (send) ;
-: addrinfo>addrspec ( addrinfo -- addrspec )
- [ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi
- parse-sockaddr ;
-
-: parse-addrinfo-list ( addrinfo -- seq )
- [ addrinfo-next ] follow
- [ addrinfo>addrspec ] map
- sift ;
-
-HOOK: addrinfo-error io-backend ( n -- )
-
GENERIC: resolve-host ( addrspec -- seq )
TUPLE: inet < abstract-inet ;
C: <inet> inet
-: resolve-passive-host ( -- addrspecs )
- { T{ inet6 f "::" f } T{ inet4 f "0.0.0.0" f } } [ clone ] map ;
-
-: prepare-addrinfo ( -- addrinfo )
- "addrinfo" <c-object>
- PF_UNSPEC over set-addrinfo-family
- IPPROTO_TCP over set-addrinfo-protocol ;
-
-: fill-in-ports ( addrspecs port -- addrspecs )
- '[ _ >>port ] map ;
-
M: inet resolve-host
[ port>> ] [ host>> ] bi [
f prepare-addrinfo f <void*>
- [ getaddrinfo addrinfo-error ] keep *void*
+ [ getaddrinfo addrinfo-error ] keep *void* addrinfo memory>struct
[ parse-addrinfo-list ] keep freeaddrinfo
] [ resolve-passive-host ] if*
swap fill-in-ports ;
! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings generic kernel math threads
-sequences byte-arrays io.binary io.backend.unix io.streams.duplex
-io.backend io.pathnames io.files.private io.encodings.utf8 math.parser
-continuations libc combinators system accessors destructors unix
-locals init ;
+USING: alien alien.c-types alien.strings generic kernel math
+threads sequences byte-arrays io.binary io.backend.unix
+io.streams.duplex io.backend io.pathnames io.sockets.private
+io.files.private io.encodings.utf8 math.parser continuations
+libc combinators system accessors destructors unix locals init
+classes.struct ;
EXCLUDE: namespaces => bind ;
EXCLUDE: io => read write ;
M: unix addrinfo-error ( n -- )
[ gai_strerror throw ] unless-zero ;
+M: unix sockaddr-of-family ( alien af -- addrspec )
+ {
+ { AF_INET [ sockaddr-in memory>struct ] }
+ { AF_INET6 [ sockaddr-in6 memory>struct ] }
+ { AF_UNIX [ sockaddr-un memory>struct ] }
+ [ 2drop f ]
+ } case ;
+
+M: unix addrspec-of-family ( af -- addrspec )
+ {
+ { AF_INET [ T{ inet4 } ] }
+ { AF_INET6 [ T{ inet6 } ] }
+ { AF_UNIX [ T{ local } ] }
+ [ drop f ]
+ } case ;
+
! Client sockets - TCP and Unix domain
M: object (get-local-address) ( handle remote -- sockaddr )
[ handle-fd ] dip empty-sockaddr/size <int>
[ packet-size malloc receive-buffer set-global ] "io.sockets.unix" add-init-hook
:: do-receive ( port -- packet sockaddr )
- port addr>> empty-sockaddr/size [| sockaddr len |
- port handle>> handle-fd ! s
- receive-buffer get-global ! buf
- packet-size ! nbytes
- 0 ! flags
- sockaddr ! from
- len <int> ! fromlen
- recvfrom dup 0 >= [
- receive-buffer get-global swap memory>byte-array sockaddr
- ] [
- drop f f
- ] if
- ] call ;
+ port addr>> empty-sockaddr/size :> len :> sockaddr
+ port handle>> handle-fd ! s
+ receive-buffer get-global ! buf
+ packet-size ! nbytes
+ 0 ! flags
+ sockaddr ! from
+ len <int> ! fromlen
+ recvfrom dup 0 >=
+ [ receive-buffer get-global swap memory>byte-array sockaddr ]
+ [ drop f f ]
+ if ;
M: unix (receive) ( datagram -- packet sockaddr )
dup do-receive dup [ [ drop ] 2dip ] [
! Unix domain sockets
M: local protocol-family drop PF_UNIX ;
-M: local sockaddr-size drop "sockaddr-un" heap-size ;
+M: local sockaddr-size drop sockaddr-un heap-size ;
-M: local empty-sockaddr drop "sockaddr-un" <c-object> ;
+M: local empty-sockaddr drop sockaddr-un <struct> ;
M: local make-sockaddr
path>> (normalize-path)
dup length 1 + max-un-path > [ "Path too long" throw ] when
- "sockaddr-un" <c-object>
- AF_UNIX over set-sockaddr-un-family
- [ [ utf8 string>alien ] dip set-sockaddr-un-path ] keep ;
+ sockaddr-un <struct>
+ AF_UNIX >>family
+ swap utf8 string>alien >>path ;
M: local parse-sockaddr
drop
- sockaddr-un-path utf8 alien>string <local> ;
+ path>> utf8 alien>string <local> ;
USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.ports io.timeouts io.sockets
-io namespaces io.streams.duplex io.backend.windows
-io.sockets.windows io.backend.windows.nt windows.winsock kernel
-libc math sequences threads system combinators accessors
-classes.struct windows.kernel32 ;
+io.sockets.private io namespaces io.streams.duplex
+io.backend.windows io.sockets.windows io.backend.windows.nt
+windows.winsock kernel libc math sequences threads system
+combinators accessors classes.struct windows.kernel32 ;
IN: io.sockets.windows.nt
-: malloc-int ( object -- object )
- "int" heap-size malloc [ nip ] [ 0 set-alien-signed-4 ] 2bi ; inline
+: malloc-int ( n -- alien )
+ <int> malloc-byte-array ; inline
M: winnt WSASocket-flags ( -- DWORD )
WSA_FLAG_OVERLAPPED ;
} cleave AcceptEx drop
winsock-error-string [ throw ] when* ; inline
+: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
+ f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
+
: extract-remote-address ( AcceptEx -- sockaddr )
- {
- [ lpOutputBuffer>> ]
- [ dwReceiveDataLength>> ]
- [ dwLocalAddressLength>> ]
- [ dwRemoteAddressLength>> ]
- } cleave
- f <void*>
- 0 <int>
- f <void*>
- [ 0 <int> GetAcceptExSockaddrs ] keep *void* ; inline
+ [
+ {
+ [ lpOutputBuffer>> ]
+ [ dwReceiveDataLength>> ]
+ [ dwLocalAddressLength>> ]
+ [ dwRemoteAddressLength>> ]
+ } cleave
+ (extract-remote-address)
+ ] [ port>> addr>> protocol-family ] bi
+ sockaddr-of-family ; inline
M: object (accept) ( server addr -- handle sockaddr )
[
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
[ lpBuffers>> buf>> swap memory>byte-array ]
- [ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline
+ [
+ [ port>> addr>> empty-sockaddr dup ]
+ [ lpFrom>> ]
+ [ lpFromLen>> *int ]
+ tri memcpy
+ ] bi ; inline
M: winnt (receive) ( datagram -- packet addrspec )
[
-USING: kernel accessors io.sockets io.backend.windows io.backend\r
-windows.winsock system destructors alien.c-types ;\r
+USING: kernel accessors io.sockets io.sockets.private\r
+io.backend.windows io.backend windows.winsock system destructors\r
+alien.c-types classes.struct combinators ;\r
IN: io.sockets.windows\r
\r
+M: windows addrinfo-error ( n -- )\r
+ winsock-return-check ;\r
+\r
+M: windows sockaddr-of-family ( alien af -- addrspec )\r
+ {\r
+ { AF_INET [ sockaddr-in memory>struct ] }\r
+ { AF_INET6 [ sockaddr-in6 memory>struct ] }\r
+ [ 2drop f ]\r
+ } case ;\r
+\r
+M: windows addrspec-of-family ( af -- addrspec )\r
+ {\r
+ { AF_INET [ T{ inet4 } ] }\r
+ { AF_INET6 [ T{ inet6 } ] }\r
+ [ drop f ]\r
+ } case ;\r
+\r
HOOK: WSASocket-flags io-backend ( -- DWORD )\r
\r
TUPLE: win32-socket < win32-file ;\r
handle>> closesocket drop ;\r
\r
: unspecific-sockaddr/size ( addrspec -- sockaddr len )\r
- [ empty-sockaddr/size ] [ protocol-family ] bi\r
- pick set-sockaddr-in-family ;\r
+ [ empty-sockaddr/size ] [ protocol-family ] bi pick (>>family) ;\r
\r
: opened-socket ( handle -- win32-socket )\r
<win32-socket> |dispose dup add-completion ;\r
\r
M: windows (datagram) ( addrspec -- handle )\r
[ SOCK_DGRAM server-socket ] with-destructors ;\r
-\r
-M: windows addrinfo-error ( n -- )\r
- winsock-return-check ;\r
dup length zero? not [ rest ] [ drop f ] if ;
: (match-first) ( seq pattern-seq -- bindings leftover/f )
- 2dup [ length ] bi@ < [ 2drop f f ]
- [
+ 2dup shorter? [ 2drop f f ] [
2dup length head over match
- [ nip swap ?1-tail ] [ [ rest ] dip (match-first) ] if*
+ [ swap ?1-tail ] [ [ rest ] dip (match-first) ] ?if
] if ;
: match-first ( seq pattern-seq -- bindings )
: (match-all) ( seq pattern-seq -- )
[ nip ] [ (match-first) swap ] 2bi
- [
- , [ swap (match-all) ] [ drop ] if*
- ] [ 2drop ] if* ;
+ [ , [ swap (match-all) ] [ drop ] if* ] [ 2drop ] if* ;
: match-all ( seq pattern-seq -- bindings-seq )
[ (match-all) ] { } make ;
-
math math.blas.ffi math.blas.vectors math.blas.vectors.private
math.complex math.functions math.order functors words
sequences sequences.merged sequences.private shuffle
-specialized-arrays.direct.float specialized-arrays.direct.double
specialized-arrays.float specialized-arrays.double
-specialized-arrays.direct.complex-float specialized-arrays.direct.complex-double
specialized-arrays.complex-float specialized-arrays.complex-double
parser prettyprint.backend prettyprint.custom ascii ;
IN: math.blas.matrices
math.complex math.functions math.order sequences sequences.private
functors words locals parser prettyprint.backend prettyprint.custom
specialized-arrays.float specialized-arrays.double
-specialized-arrays.direct.float specialized-arrays.direct.double
-specialized-arrays.complex-float specialized-arrays.complex-double
-specialized-arrays.direct.complex-float
-specialized-arrays.direct.complex-double ;
+specialized-arrays.complex-float specialized-arrays.complex-double ;
IN: math.blas.vectors
TUPLE: blas-vector-base underlying length inc ;
{ $subsection euler }
{ $subsection phi }
{ $subsection pi }
-{ $subsection epsilon } ;
+{ $subsection epsilon }
+{ $subsection single-epsilon } ;
ABOUT: "math-constants"
{ $values { "pi" "circumference of circle with diameter 1" } } ;
HELP: epsilon
-{ $values { "epsilon" "smallest floating point value you can add to 1 without underflow" } } ;
+{ $values { "epsilon" "smallest double-precision floating point value you can add to 1 without underflow" } } ;
+
+HELP: single-epsilon
+{ $values { "epsilon" "smallest single-precision floating point value you can add to 1 without underflow" } } ;
: phi ( -- phi ) 1.61803398874989484820 ; inline
: pi ( -- pi ) 3.14159265358979323846 ; inline
: 2pi ( -- pi ) 2 pi * ; inline
-: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
+: epsilon ( -- epsilon ) HEX: 3cb0000000000000 bits>double ; foldable
+: single-epsilon ( -- epsilon ) HEX: 34000000 bits>float ; foldable
: smallest-float ( -- x ) HEX: 1 bits>double ; foldable
: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable
--- /dev/null
+IN: math.vectors.simd.alien.tests
+USING: cpu.architecture math.vectors.simd
+math.vectors.simd.intrinsics accessors math.vectors.simd.alien
+kernel classes.struct tools.test compiler sequences byte-arrays
+alien math kernel.private specialized-arrays.float combinators ;
+
+! Vector alien intrinsics
+[ float-4{ 1 2 3 4 } ] [
+ [
+ float-4{ 1 2 3 4 }
+ underlying>> 0 float-4-rep alien-vector
+ ] compile-call float-4 boa
+] unit-test
+
+[ B{ 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 } ] [
+ 16 [ 1 ] B{ } replicate-as 16 <byte-array>
+ [
+ 0 [
+ { byte-array c-ptr fixnum } declare
+ float-4-rep set-alien-vector
+ ] compile-call
+ ] keep
+] unit-test
+
+[ float-array{ 1 2 3 4 } ] [
+ [
+ float-array{ 1 2 3 4 } underlying>>
+ float-array{ 4 3 2 1 } clone
+ [ underlying>> 0 float-4-rep set-alien-vector ] keep
+ ] compile-call
+] unit-test
+
+STRUCT: simd-struct
+{ x float-4 }
+{ y double-2 }
+{ z double-4 }
+{ w float-8 } ;
+
+[ t ] [ [ simd-struct <struct> ] compile-call >c-ptr [ 0 = ] all? ] unit-test
+
+[
+ float-4{ 1 2 3 4 }
+ double-2{ 2 1 }
+ double-4{ 4 3 2 1 }
+ float-8{ 1 2 3 4 5 6 7 8 }
+] [
+ simd-struct <struct>
+ float-4{ 1 2 3 4 } >>x
+ double-2{ 2 1 } >>y
+ double-4{ 4 3 2 1 } >>z
+ float-8{ 1 2 3 4 5 6 7 8 } >>w
+ { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
+] unit-test
+
+[
+ float-4{ 1 2 3 4 }
+ double-2{ 2 1 }
+ double-4{ 4 3 2 1 }
+ float-8{ 1 2 3 4 5 6 7 8 }
+] [
+ [
+ simd-struct <struct>
+ float-4{ 1 2 3 4 } >>x
+ double-2{ 2 1 } >>y
+ double-4{ 4 3 2 1 } >>z
+ float-8{ 1 2 3 4 5 6 7 8 } >>w
+ { [ x>> ] [ y>> ] [ z>> ] [ w>> ] } cleave
+ ] compile-call
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien accessors alien.c-types byte-arrays compiler.units
+cpu.architecture locals kernel math math.vectors.simd
+math.vectors.simd.intrinsics ;
+IN: math.vectors.simd.alien
+
+:: define-simd-128-type ( class rep -- )
+ <c-type>
+ byte-array >>class
+ class >>boxed-class
+ [ rep alien-vector class boa ] >>getter
+ [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter
+ 16 >>size
+ 8 >>align
+ rep >>rep
+ class name>> typedef ;
+
+:: define-simd-256-type ( class rep -- )
+ <c-type>
+ class >>class
+ class >>boxed-class
+ [
+ [ rep alien-vector ]
+ [ 16 + >fixnum rep alien-vector ] 2bi
+ class boa
+ ] >>getter
+ [
+ [ [ underlying1>> ] 2dip rep set-alien-vector ]
+ [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ]
+ 3bi
+ ] >>setter
+ 32 >>size
+ 8 >>align
+ rep >>rep
+ class name>> typedef ;
+[
+ float-4 float-4-rep define-simd-128-type
+ double-2 double-2-rep define-simd-128-type
+ float-8 float-4-rep define-simd-256-type
+ double-4 double-2-rep define-simd-256-type
+] with-compilation-unit
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types byte-arrays classes functors
+kernel math parser prettyprint.custom sequences
+sequences.private literals ;
+IN: math.vectors.simd.functor
+
+ERROR: bad-length got expected ;
+
+FUNCTOR: define-simd-128 ( T -- )
+
+N [ 16 T heap-size /i ]
+
+A DEFINES-CLASS ${T}-${N}
+>A DEFINES >${A}
+A{ DEFINES ${A}{
+
+NTH [ T dup c-type-getter-boxer array-accessor ]
+SET-NTH [ T dup c-setter array-accessor ]
+
+A-rep IS ${A}-rep
+A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
+A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
+
+WHERE
+
+TUPLE: A
+{ underlying byte-array read-only initial: $[ 16 <byte-array> ] } ;
+
+M: A clone underlying>> clone \ A boa ; inline
+
+M: A length drop N ; inline
+
+M: A nth-unsafe underlying>> NTH call ; inline
+
+M: A set-nth-unsafe underlying>> SET-NTH call ; inline
+
+: >A ( seq -- simd-array ) \ A new clone-like ;
+
+M: A like drop dup \ A instance? [ >A ] unless ; inline
+
+M: A new-sequence
+ drop dup N =
+ [ drop 16 <byte-array> \ A boa ]
+ [ N bad-length ]
+ if ; inline
+
+M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
+
+M: A byte-length underlying>> length ; inline
+
+M: A pprint-delims drop \ A{ \ } ;
+
+M: A >pprint-sequence ;
+
+M: A pprint* pprint-object ;
+
+SYNTAX: A{ \ } [ >A ] parse-literal ;
+
+INSTANCE: A sequence
+
+<PRIVATE
+
+: A-vv->v-op ( v1 v2 quot -- v3 )
+ [ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline
+
+: A-v->n-op ( v quot -- n )
+ [ underlying>> A-rep ] dip call ; inline
+
+PRIVATE>
+
+;FUNCTOR
+
+! Synthesize 256-bit vectors from a pair of 128-bit vectors
+FUNCTOR: define-simd-256 ( T -- )
+
+N [ 32 T heap-size /i ]
+
+N/2 [ N 2 / ]
+A/2 IS ${T}-${N/2}
+
+A DEFINES-CLASS ${T}-${N}
+>A DEFINES >${A}
+A{ DEFINES ${A}{
+
+A-deref DEFINES-PRIVATE ${A}-deref
+
+A-rep IS ${A/2}-rep
+A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
+A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
+
+WHERE
+
+SLOT: underlying1
+SLOT: underlying2
+
+TUPLE: A
+{ underlying1 byte-array initial: $[ 16 <byte-array> ] read-only }
+{ underlying2 byte-array initial: $[ 16 <byte-array> ] read-only } ;
+
+M: A clone
+ [ underlying1>> clone ] [ underlying2>> clone ] bi
+ \ A boa ; inline
+
+M: A length drop N ; inline
+
+: A-deref ( n seq -- n' seq' )
+ over N/2 < [ underlying1>> ] [ [ N/2 - ] dip underlying2>> ] if \ A/2 boa ; inline
+
+M: A nth-unsafe A-deref nth-unsafe ; inline
+
+M: A set-nth-unsafe A-deref set-nth-unsafe ; inline
+
+: >A ( seq -- simd-array ) \ A new clone-like ;
+
+M: A like drop dup \ A instance? [ >A ] unless ; inline
+
+M: A new-sequence
+ drop dup N =
+ [ drop 16 <byte-array> 16 <byte-array> \ A boa ]
+ [ N bad-length ]
+ if ; inline
+
+M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
+
+M: A byte-length drop 32 ; inline
+
+SYNTAX: A{ \ } [ >A ] parse-literal ;
+
+M: A pprint-delims drop \ A{ \ } ;
+
+M: A >pprint-sequence ;
+
+M: A pprint* pprint-object ;
+
+INSTANCE: A sequence
+
+: A-vv->v-op ( v1 v2 quot -- v3 )
+ [ [ [ underlying1>> ] bi@ A-rep ] dip call ]
+ [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
+ \ A boa ; inline
+
+: A-v->n-op ( v1 combine-quot reduce-quot -- v2 )
+ [ [ [ underlying1>> ] [ underlying2>> ] bi A-rep ] dip call A-rep ]
+ dip call ; inline
+
+;FUNCTOR
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel alien alien.c-types cpu.architecture libc ;
+IN: math.vectors.simd.intrinsics
+
+ERROR: bad-simd-call ;
+
+: (simd-v+) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-v-) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-v*) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-v/) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-vmin) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-vmax) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-vsqrt) ( v1 v2 rep -- v3 ) bad-simd-call ;
+: (simd-sum) ( v1 rep -- v2 ) bad-simd-call ;
+: (simd-broadcast) ( x rep -- v ) bad-simd-call ;
+: (simd-gather-2) ( a b rep -- v ) bad-simd-call ;
+: (simd-gather-4) ( a b c d rep -- v ) bad-simd-call ;
+: assert-positive ( x -- y ) ;
+
+: alien-vector ( c-ptr n rep -- value )
+ ! Inefficient version for when intrinsics are missing
+ [ swap <displaced-alien> ] dip rep-size memory>byte-array ;
+
+: set-alien-vector ( value c-ptr n rep -- )
+ ! Inefficient version for when intrinsics are missing
+ [ swap <displaced-alien> swap ] dip rep-size memcpy ;
+
--- /dev/null
+USING: help.markup help.syntax sequences math math.vectors
+multiline kernel.private classes.tuple.private
+math.vectors.simd.intrinsics cpu.architecture ;
+IN: math.vectors.simd
+
+ARTICLE: "math.vectors.simd.intro" "Introduction to SIMD support"
+"Modern CPUs support a form of data-level parallelism, where arithmetic operations on fixed-size short vectors can be done on all components in parallel. This is known as single-instruction-multiple-data (SIMD)."
+$nl
+"SIMD support in the processor takes the form of instruction sets which operate on vector registers. By operating on multiple scalar values at the same time, code which operates on points, colors, and other vector data can be sped up."
+$nl
+"In Factor, SIMD support is exposed in the form of special-purpose SIMD " { $link "sequence-protocol" } " implementations. These are fixed-length, homogeneous sequences. They are referred to as vectors, but should not be confused with Factor's " { $link "vectors" } ", which can hold any type of object and can be resized.)."
+$nl
+"The words in the " { $vocab-link "math.vectors" } " vocabulary, which can be used with any sequence of numbers, are special-cased by the compiler. If the compiler can prove that only SIMD vectors are used, it expands " { $link "math-vectors" } " into " { $link "math.vectors.simd.intrinsics" } ". While in the general case, SIMD intrinsics operate on heap-allocated SIMD vectors, that too can be optimized since in many cases the compiler unbox SIMD vectors, storing them directly in registers."
+$nl
+"Since the only difference between ordinary code and SIMD-accelerated code is that the latter uses special fixed-length SIMD sequences, the SIMD library is very easy to use. To ensure your code compiles to use vector instructions without boxing and unboxing overhead, follow the guidelines for " { $link "math.vectors.simd.efficiency" } "."
+$nl
+"There should never be any reason to use " { $link "math.vectors.simd.intrinsics" } " directly, but they too have a straightforward, but lower-level, interface." ;
+
+ARTICLE: "math.vectors.simd.support" "Supported SIMD instruction sets and operations"
+"At present, the SIMD support makes use of SSE2 and a few SSE3 instructions on x86 CPUs."
+$nl
+"SSE3 introduces horizontal adds (summing all components of a single vector register), which is useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } ". If SSE3 is not available, software fallbacks are used for " { $link sum } " and related words, decreasing performance."
+$nl
+"On PowerPC, or older x86 chips without SSE2, software fallbacks are used for all high-level vector operations. SIMD code can run with no loss in functionality, just decreased performance."
+$nl
+"The primities in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary do not have software fallbacks, but they should not be called directly in any case." ;
+
+ARTICLE: "math.vectors.simd.types" "SIMD vector types"
+"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type such as " { $snippet "float" } " or " { $snippet "double" } ", and " { $snippet "count" } " is a vector dimension, such as 2, 4, or 8."
+$nl
+"The following vector types are defined:"
+{ $subsection float-4 }
+{ $subsection double-2 }
+{ $subsection float-8 }
+{ $subsection double-4 }
+"For each vector type, several words are defined:"
+{ $table
+ { "Word" "Stack effect" "Description" }
+ { { $snippet "type-with" } { $snippet "( x -- simd-array )" } "creates a new instance where all components are set to a single scalar" }
+ { { $snippet "type-boa" } { $snippet "( ... -- simd-array )" } "creates a new instance where components are read from the stack" }
+ { { $snippet ">type" } { $snippet "( seq -- simd-array )" } "creates a new instance initialized with the elements of an existing sequence, which must have the correct length" }
+ { { $snippet "type{" } { $snippet "type{ elements... }" } "parsing word defining literal syntax for an SIMD vector; the correct number of elements must be given" }
+}
+"The " { $link float-4 } " and " { $link double-2 } " types correspond to 128-bit vector registers. The " { $link float-8 } " and " { $link double-4 } " types are not directly supported in hardware, and instead unbox to a pair of 128-bit vector registers."
+$nl
+"Operations on " { $link float-4 } " instances:"
+{ $subsection float-4-with }
+{ $subsection float-4-boa }
+{ $subsection POSTPONE: float-4{ }
+"Operations on " { $link double-2 } " instances:"
+{ $subsection double-2-with }
+{ $subsection double-2-boa }
+{ $subsection POSTPONE: double-2{ }
+"Operations on " { $link float-8 } " instances:"
+{ $subsection float-8-with }
+{ $subsection float-8-boa }
+{ $subsection POSTPONE: float-8{ }
+"Operations on " { $link double-4 } " instances:"
+{ $subsection double-4-with }
+{ $subsection double-4-boa }
+{ $subsection POSTPONE: double-4{ }
+"To actually perform vector arithmetic on SIMD vectors, use " { $link "math-vectors" } " words."
+{ $see-also "c-types-specs" } ;
+
+ARTICLE: "math.vectors.simd.efficiency" "Writing efficient SIMD code"
+"Since SIMD vectors are heap-allocated objects, it is important to write code in a style which is conducive to the compiler being able to inline generic dispatch and eliminate allocation."
+$nl
+"If the inputs to a " { $vocab-link "math.vectors" } " word are statically known to be SIMD vectors, the call is converted into an SIMD primitive, and the output is then also known to be an SIMD vector (or scalar, depending on the operation); this information propagates forward within a single word (together with any inlined words and macro expansions). Any intermediate values which are not stored into collections, or returned from the word, are furthermore unboxed."
+$nl
+"To check if optimizations are being performed, pass a quotation to the " { $snippet "optimizer-report." } " and " { $snippet "optimized." } " words in the " { $vocab-link "compiler.tree.debugger" } " vocabulary, and look for calls to " { $link "math.vectors.simd.intrinsics" } " as opposed to high-level " { $link "math-vectors" } "."
+$nl
+"For example, in the following, no SIMD operations are used at all, because the compiler's propagation pass does not consider dynamic variable usage:"
+{ $code
+<" USING: compiler.tree.debugger math.vectors
+math.vectors.simd ;
+SYMBOLS: x y ;
+
+[
+ double-4{ 1.5 2.0 3.7 0.4 } x set
+ double-4{ 1.5 2.0 3.7 0.4 } y set
+ x get y get v+
+] optimizer-report."> }
+"The following word benefits from SIMD optimization, because it begins with an unsafe declaration:"
+{ $code
+<" USING: compiler.tree.debugger kernel.private
+math.vectors math.vectors.simd ;
+
+: interpolate ( v a b -- w )
+ { float-4 float-4 float-4 } declare
+ [ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ;
+
+\ interpolate optimizer-report. "> }
+"Note that using " { $link declare } " is not recommended. Safer ways of getting type information for the input parameters to a word include defining methods on a generic word (the value being dispatched upon has a statically known type in the method body), as well as using " { $link "hints" } " and " { $link POSTPONE: inline } " declarations."
+$nl
+"Here is a better version of the " { $snippet "interpolate" } " words above that uses hints:"
+{ $code
+<" USING: compiler.tree.debugger hints
+math.vectors math.vectors.simd ;
+
+: interpolate ( v a b -- w )
+ [ v* ] [ [ 1.0 ] dip n-v v* ] bi-curry* bi v+ ;
+
+HINTS: interpolate float-4 float-4 float-4 ;
+
+\ interpolate optimizer-report. "> }
+"This time, the optimizer report lists calls to both SIMD primitives and high-level vector words, because hints cause two code paths to be generated. The " { $snippet "optimized." } " word can be used to make sure that the fast code path consists entirely of calls to primitives."
+$nl
+"If the " { $snippet "interpolate" } " word was to be used in several places with different types of vectors, it would be best to declare it " { $link POSTPONE: inline } "."
+$nl
+"In the " { $snippet "interpolate" } " word, there is still a call to the " { $link <tuple-boa> } " primitive, because the return value at the end is being boxed on the heap. In the next example, no memory allocation occurs at all because the SIMD vectors are stored inside a struct class (see " { $link "classes.struct" } "); also note the use of inlining:"
+{ $code
+<" USING: compiler.tree.debugger math.vectors math.vectors.simd ;
+IN: simd-demo
+
+STRUCT: actor
+{ id int }
+{ position float-4 }
+{ velocity float-4 }
+{ acceleration float-4 } ;
+
+GENERIC: advance ( dt object -- )
+
+: update-velocity ( dt actor -- )
+ [ acceleration>> n*v ] [ velocity>> v+ ] [ ] tri
+ (>>velocity) ; inline
+
+: update-position ( dt actor -- )
+ [ velocity>> n*v ] [ position>> v+ ] [ ] tri
+ (>>position) ; inline
+
+M: actor advance ( dt actor -- )
+ [ >float ] dip
+ [ update-velocity ] [ update-position ] 2bi ;
+
+M\ actor advance optimized.">
+}
+"The " { $vocab-link "compiler.cfg.debugger" } " vocabulary can give a lower-level picture of the generated code, that includes register assignments and other low-level details. To look at low-level optimizer output, call " { $snippet "test-mr mr." } " on a word or quotation:"
+{ $code
+<" USE: compiler.tree.debugger
+
+M\ actor advance test-mr mr.">
+"An example of a high-performance algorithm that uses SIMD primitives can be found in the " { $vocab-link "benchmark.nbody-simd" } " vocabulary." } ;
+
+ARTICLE: "math.vectors.simd.intrinsics" "Low-level SIMD primitives"
+"The words in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary are used to implement SIMD support. These words have three disadvantages compared to the higher-level " { $link "math-vectors" } " words:"
+{ $list
+ "They operate on raw byte arrays, with a separate “representation” parameter passed in to determine the type of the operands and result."
+ "They are unsafe; passing values which are not byte arrays, or byte arrays with the wrong size, will dereference invalid memory and possibly crash Factor."
+ { "They do not have software fallbacks; if the current CPU does not have SIMD support, a " { $link bad-simd-call } " error will be thrown." }
+}
+"The compiler converts " { $link "math-vectors" } " into SIMD primitives automatically in cases where it is safe; this means that the input types are known to be SIMD vectors, and the CPU supports SIMD."
+$nl
+"It is best to avoid calling these primitives directly. To write efficient high-level code that compiles down to primitives and avoids memory allocation, see " { $link "math.vectors.simd.efficiency" } "."
+{ $subsection (simd-v+) }
+{ $subsection (simd-v-) }
+{ $subsection (simd-v/) }
+{ $subsection (simd-vmin) }
+{ $subsection (simd-vmax) }
+{ $subsection (simd-vsqrt) }
+{ $subsection (simd-sum) }
+{ $subsection (simd-broadcast) }
+{ $subsection (simd-gather-2) }
+{ $subsection (simd-gather-4) }
+"There are two primitives which are used to implement accessing SIMD vector fields of " { $link "classes.struct" } ":"
+{ $subsection alien-vector }
+{ $subsection set-alien-vector }
+"For the most part, the above primitives correspond directly to vector arithmetic words. They take a representation parameter, which is one of the singleton members of the " { $link vector-rep } " union in the " { $vocab-link "cpu.architecture" } " vocabulary." ;
+
+ARTICLE: "math.vectors.simd.alien" "SIMD data in struct classes"
+"Struct classes may contain fields which store SIMD data; use one of the following C type names:"
+{ $code
+<" float-4
+double-2
+float-8
+double-4"> }
+"Passing SIMD data as function parameters is not yet supported." ;
+
+ARTICLE: "math.vectors.simd" "Hardware vector arithmetic (SIMD)"
+"The " { $vocab-link "math.vectors.simd" } " vocabulary extends the " { $vocab-link "math.vectors" } " vocabulary to support efficient vector arithmetic on small, fixed-size vectors."
+{ $subsection "math.vectors.simd.intro" }
+{ $subsection "math.vectors.simd.types" }
+{ $subsection "math.vectors.simd.support" }
+{ $subsection "math.vectors.simd.efficiency" }
+{ $subsection "math.vectors.simd.alien" }
+{ $subsection "math.vectors.simd.intrinsics" } ;
+
+! ! ! float-4
+
+HELP: float-4
+{ $class-description "A sequence of four single-precision floating point values. New instances can be created with " { $link float-4-with } " or " { $link float-4-boa } "." } ;
+
+HELP: float-4-with
+{ $values { "x" float } { "simd-array" float-4 } }
+{ $description "Creates a new vector with all four components equal to a scalar." } ;
+
+HELP: float-4-boa
+{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" float-4 } }
+{ $description "Creates a new vector from four scalar components." } ;
+
+HELP: float-4{
+{ $syntax "float-4{ a b c d }" }
+{ $description "Literal syntax for a " { $link float-4 } "." } ;
+
+! ! ! double-2
+
+HELP: double-2
+{ $class-description "A sequence of two double-precision floating point values. New instances can be created with " { $link double-2-with } " or " { $link double-2-boa } "." } ;
+
+HELP: double-2-with
+{ $values { "x" float } { "simd-array" double-2 } }
+{ $description "Creates a new vector with both components equal to a scalar." } ;
+
+HELP: double-2-boa
+{ $values { "a" float } { "b" float } { "simd-array" double-2 } }
+{ $description "Creates a new vector from two scalar components." } ;
+
+HELP: double-2{
+{ $syntax "double-2{ a b }" }
+{ $description "Literal syntax for a " { $link double-2 } "." } ;
+
+! ! ! float-8
+
+HELP: float-8
+{ $class-description "A sequence of eight single-precision floating point values. New instances can be created with " { $link float-8-with } " or " { $link float-8-boa } "." } ;
+
+HELP: float-8-with
+{ $values { "x" float } { "simd-array" float-8 } }
+{ $description "Creates a new vector with all eight components equal to a scalar." } ;
+
+HELP: float-8-boa
+{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "e" float } { "f" float } { "g" float } { "h" float } { "simd-array" float-8 } }
+{ $description "Creates a new vector from eight scalar components." } ;
+
+HELP: float-8{
+{ $syntax "float-8{ a b c d e f g h }" }
+{ $description "Literal syntax for a " { $link float-8 } "." } ;
+
+! ! ! double-4
+
+HELP: double-4
+{ $class-description "A sequence of four double-precision floating point values. New instances can be created with " { $link double-4-with } " or " { $link double-4-boa } "." } ;
+
+HELP: double-4-with
+{ $values { "x" float } { "simd-array" double-4 } }
+{ $description "Creates a new vector with all four components equal to a scalar." } ;
+
+HELP: double-4-boa
+{ $values { "a" float } { "b" float } { "c" float } { "d" float } { "simd-array" double-4 } }
+{ $description "Creates a new vector from four scalar components." } ;
+
+HELP: double-4{
+{ $syntax "double-4{ a b c d }" }
+{ $description "Literal syntax for a " { $link double-4 } "." } ;
+
+ABOUT: "math.vectors.simd"
--- /dev/null
+IN: math.vectors.simd.tests
+USING: math math.vectors.simd math.vectors.simd.private
+math.vectors math.functions math.private kernel.private compiler
+sequences tools.test compiler.tree.debugger accessors kernel ;
+
+[ float-4{ 0 0 0 0 } ] [ float-4 new ] unit-test
+
+[ float-4{ 0 0 0 0 } ] [ [ float-4 new ] compile-call ] unit-test
+
+[ V{ float } ] [ [ { float-4 } declare norm-sq ] final-classes ] unit-test
+
+[ V{ float } ] [ [ { float-4 } declare norm ] final-classes ] unit-test
+
+[ float-4{ 12 12 12 12 } ] [
+ 12 [ float-4-with ] compile-call
+] unit-test
+
+[ float-4{ 1 2 3 4 } ] [
+ 1 2 3 4 [ float-4-boa ] compile-call
+] unit-test
+
+[ float-4{ 11 22 33 44 } ] [
+ float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
+ [ { float-4 float-4 } declare v+ ] compile-call
+] unit-test
+
+[ float-4{ -9 -18 -27 -36 } ] [
+ float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
+ [ { float-4 float-4 } declare v- ] compile-call
+] unit-test
+
+[ float-4{ 10 40 90 160 } ] [
+ float-4{ 1 2 3 4 } float-4{ 10 20 30 40 }
+ [ { float-4 float-4 } declare v* ] compile-call
+] unit-test
+
+[ float-4{ 10 100 1000 10000 } ] [
+ float-4{ 100 2000 30000 400000 } float-4{ 10 20 30 40 }
+ [ { float-4 float-4 } declare v/ ] compile-call
+] unit-test
+
+[ float-4{ -10 -20 -30 -40 } ] [
+ float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 }
+ [ { float-4 float-4 } declare vmin ] compile-call
+] unit-test
+
+[ float-4{ 10 20 30 40 } ] [
+ float-4{ -10 20 -30 40 } float-4{ 10 -20 30 -40 }
+ [ { float-4 float-4 } declare vmax ] compile-call
+] unit-test
+
+[ 10.0 ] [
+ float-4{ 1 2 3 4 }
+ [ { float-4 } declare sum ] compile-call
+] unit-test
+
+[ 13.0 ] [
+ float-4{ 1 2 3 4 }
+ [ { float-4 } declare sum 3.0 + ] compile-call
+] unit-test
+
+[ 8.0 ] [
+ float-4{ 1 2 3 4 } float-4{ 2 0 2 0 }
+ [ { float-4 float-4 } declare v. ] compile-call
+] unit-test
+
+[ float-4{ 5 10 15 20 } ] [
+ 5.0 float-4{ 1 2 3 4 }
+ [ { float float-4 } declare n*v ] compile-call
+] unit-test
+
+[ float-4{ 5 10 15 20 } ] [
+ float-4{ 1 2 3 4 } 5.0
+ [ { float float-4 } declare v*n ] compile-call
+] unit-test
+
+[ float-4{ 10 5 2 5 } ] [
+ 10.0 float-4{ 1 2 5 2 }
+ [ { float float-4 } declare n/v ] compile-call
+] unit-test
+
+[ float-4{ 0.5 1 1.5 2 } ] [
+ float-4{ 1 2 3 4 } 2
+ [ { float float-4 } declare v/n ] compile-call
+] unit-test
+
+[ float-4{ 1 0 0 0 } ] [
+ float-4{ 10 0 0 0 }
+ [ { float-4 } declare normalize ] compile-call
+] unit-test
+
+[ 30.0 ] [
+ float-4{ 1 2 3 4 }
+ [ { float-4 } declare norm-sq ] compile-call
+] unit-test
+
+[ t ] [
+ float-4{ 1 0 0 0 }
+ float-4{ 0 1 0 0 }
+ [ { float-4 float-4 } declare distance ] compile-call
+ 2 sqrt 1.0e-6 ~
+] unit-test
+
+[ double-2{ 12 12 } ] [
+ 12 [ double-2-with ] compile-call
+] unit-test
+
+[ double-2{ 1 2 } ] [
+ 1 2 [ double-2-boa ] compile-call
+] unit-test
+
+[ double-2{ 11 22 } ] [
+ double-2{ 1 2 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v+ ] compile-call
+] unit-test
+
+[ double-2{ -9 -18 } ] [
+ double-2{ 1 2 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v- ] compile-call
+] unit-test
+
+[ double-2{ 10 40 } ] [
+ double-2{ 1 2 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v* ] compile-call
+] unit-test
+
+[ double-2{ 10 100 } ] [
+ double-2{ 100 2000 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v/ ] compile-call
+] unit-test
+
+[ double-2{ -10 -20 } ] [
+ double-2{ -10 20 } double-2{ 10 -20 }
+ [ { double-2 double-2 } declare vmin ] compile-call
+] unit-test
+
+[ double-2{ 10 20 } ] [
+ double-2{ -10 20 } double-2{ 10 -20 }
+ [ { double-2 double-2 } declare vmax ] compile-call
+] unit-test
+
+[ 3.0 ] [
+ double-2{ 1 2 }
+ [ { double-2 } declare sum ] compile-call
+] unit-test
+
+[ 7.0 ] [
+ double-2{ 1 2 }
+ [ { double-2 } declare sum 4.0 + ] compile-call
+] unit-test
+
+[ 16.0 ] [
+ double-2{ 1 2 } double-2{ 2 7 }
+ [ { double-2 double-2 } declare v. ] compile-call
+] unit-test
+
+[ double-2{ 5 10 } ] [
+ 5.0 double-2{ 1 2 }
+ [ { float double-2 } declare n*v ] compile-call
+] unit-test
+
+[ double-2{ 5 10 } ] [
+ double-2{ 1 2 } 5.0
+ [ { float double-2 } declare v*n ] compile-call
+] unit-test
+
+[ double-2{ 10 5 } ] [
+ 10.0 double-2{ 1 2 }
+ [ { float double-2 } declare n/v ] compile-call
+] unit-test
+
+[ double-2{ 0.5 1 } ] [
+ double-2{ 1 2 } 2
+ [ { float double-2 } declare v/n ] compile-call
+] unit-test
+
+[ double-2{ 0 0 } ] [ double-2 new ] unit-test
+
+[ double-2{ 1 0 } ] [
+ double-2{ 10 0 }
+ [ { double-2 } declare normalize ] compile-call
+] unit-test
+
+[ 5.0 ] [
+ double-2{ 1 2 }
+ [ { double-2 } declare norm-sq ] compile-call
+] unit-test
+
+[ t ] [
+ double-2{ 1 0 }
+ double-2{ 0 1 }
+ [ { double-2 double-2 } declare distance ] compile-call
+ 2 sqrt 1.0e-6 ~
+] unit-test
+
+[ double-4{ 0 0 0 0 } ] [ double-4 new ] unit-test
+
+[ double-4{ 1 2 3 4 } ] [
+ 1 2 3 4 double-4-boa
+] unit-test
+
+[ double-4{ 1 1 1 1 } ] [
+ 1 double-4-with
+] unit-test
+
+[ double-4{ 0 1 2 3 } ] [
+ 1 double-4-with [ * ] map-index
+] unit-test
+
+[ V{ float } ] [ [ { double-4 } declare norm-sq ] final-classes ] unit-test
+
+[ V{ float } ] [ [ { double-4 } declare norm ] final-classes ] unit-test
+
+[ double-4{ 12 12 12 12 } ] [
+ 12 [ double-4-with ] compile-call
+] unit-test
+
+[ double-4{ 1 2 3 4 } ] [
+ 1 2 3 4 [ double-4-boa ] compile-call
+] unit-test
+
+[ double-4{ 11 22 33 44 } ] [
+ double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
+ [ { double-4 double-4 } declare v+ ] compile-call
+] unit-test
+
+[ double-4{ -9 -18 -27 -36 } ] [
+ double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
+ [ { double-4 double-4 } declare v- ] compile-call
+] unit-test
+
+[ double-4{ 10 40 90 160 } ] [
+ double-4{ 1 2 3 4 } double-4{ 10 20 30 40 }
+ [ { double-4 double-4 } declare v* ] compile-call
+] unit-test
+
+[ double-4{ 10 100 1000 10000 } ] [
+ double-4{ 100 2000 30000 400000 } double-4{ 10 20 30 40 }
+ [ { double-4 double-4 } declare v/ ] compile-call
+] unit-test
+
+[ double-4{ -10 -20 -30 -40 } ] [
+ double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 }
+ [ { double-4 double-4 } declare vmin ] compile-call
+] unit-test
+
+[ double-4{ 10 20 30 40 } ] [
+ double-4{ -10 20 -30 40 } double-4{ 10 -20 30 -40 }
+ [ { double-4 double-4 } declare vmax ] compile-call
+] unit-test
+
+[ 10.0 ] [
+ double-4{ 1 2 3 4 }
+ [ { double-4 } declare sum ] compile-call
+] unit-test
+
+[ 13.0 ] [
+ double-4{ 1 2 3 4 }
+ [ { double-4 } declare sum 3.0 + ] compile-call
+] unit-test
+
+[ 8.0 ] [
+ double-4{ 1 2 3 4 } double-4{ 2 0 2 0 }
+ [ { double-4 double-4 } declare v. ] compile-call
+] unit-test
+
+[ double-4{ 5 10 15 20 } ] [
+ 5.0 double-4{ 1 2 3 4 }
+ [ { float double-4 } declare n*v ] compile-call
+] unit-test
+
+[ double-4{ 5 10 15 20 } ] [
+ double-4{ 1 2 3 4 } 5.0
+ [ { float double-4 } declare v*n ] compile-call
+] unit-test
+
+[ double-4{ 10 5 2 5 } ] [
+ 10.0 double-4{ 1 2 5 2 }
+ [ { float double-4 } declare n/v ] compile-call
+] unit-test
+
+[ double-4{ 0.5 1 1.5 2 } ] [
+ double-4{ 1 2 3 4 } 2
+ [ { float double-4 } declare v/n ] compile-call
+] unit-test
+
+[ double-4{ 1 0 0 0 } ] [
+ double-4{ 10 0 0 0 }
+ [ { double-4 } declare normalize ] compile-call
+] unit-test
+
+[ 30.0 ] [
+ double-4{ 1 2 3 4 }
+ [ { double-4 } declare norm-sq ] compile-call
+] unit-test
+
+[ t ] [
+ double-4{ 1 0 0 0 }
+ double-4{ 0 1 0 0 }
+ [ { double-4 double-4 } declare distance ] compile-call
+ 2 sqrt 1.0e-6 ~
+] unit-test
+
+[ float-8{ 0 0 0 0 0 0 0 0 } ] [ float-8 new ] unit-test
+
+[ float-8{ 0 0 0 0 0 0 0 0 } ] [ [ float-8 new ] compile-call ] unit-test
+
+[ float-8{ 1 1 1 1 1 1 1 1 } ] [ 1 float-8-with ] unit-test
+
+[ float-8{ 1 1 1 1 1 1 1 1 } ] [ [ 1 float-8-with ] compile-call ] unit-test
+
+[ float-8{ 1 2 3 4 5 6 7 8 } ] [ 1 2 3 4 5 6 7 8 float-8-boa ] unit-test
+
+[ float-8{ 1 2 3 4 5 6 7 8 } ] [ [ 1 2 3 4 5 6 7 8 float-8-boa ] compile-call ] unit-test
+
+[ float-8{ 3 6 9 12 15 18 21 24 } ] [
+ float-8{ 1 2 3 4 5 6 7 8 }
+ float-8{ 2 4 6 8 10 12 14 16 }
+ [ { float-8 float-8 } declare v+ ] compile-call
+] unit-test
+
+[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
+ float-8{ 1 2 3 4 5 6 7 8 }
+ float-8{ 2 4 6 8 10 12 14 16 }
+ [ { float-8 float-8 } declare v- ] compile-call
+] unit-test
+
+[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
+ -0.5
+ float-8{ 2 4 6 8 10 12 14 16 }
+ [ { float float-8 } declare n*v ] compile-call
+] unit-test
+
+[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
+ float-8{ 2 4 6 8 10 12 14 16 }
+ -0.5
+ [ { float-8 float } declare v*n ] compile-call
+] unit-test
+
+[ float-8{ 256 128 64 32 16 8 4 2 } ] [
+ 256.0
+ float-8{ 1 2 4 8 16 32 64 128 }
+ [ { float float-8 } declare n/v ] compile-call
+] unit-test
+
+[ float-8{ -1 -2 -3 -4 -5 -6 -7 -8 } ] [
+ float-8{ 2 4 6 8 10 12 14 16 }
+ -2.0
+ [ { float-8 float } declare v/n ] compile-call
+] unit-test
+
+! Test puns
+[ double-2{ 4 1024 } ] [
+ float-4{ 0 1 0 2 }
+ [ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call
+] unit-test
+
+[ 33.0 ] [
+ double-2{ 1 2 } double-2{ 10 20 }
+ [ { double-2 double-2 } declare v+ underlying>> 3.0 float* ] compile-call
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types byte-arrays cpu.architecture
+kernel math math.functions math.vectors
+math.vectors.simd.functor math.vectors.simd.intrinsics
+math.vectors.specialization parser prettyprint.custom sequences
+sequences.private specialized-arrays.double locals assocs
+words fry ;
+IN: math.vectors.simd
+
+<<
+
+DEFER: float-4
+DEFER: double-2
+DEFER: float-8
+DEFER: double-4
+
+"double" define-simd-128
+"float" define-simd-128
+"double" define-simd-256
+"float" define-simd-256
+
+>>
+
+: float-4-with ( x -- simd-array )
+ [ 4 ] dip >float '[ _ ] \ float-4 new replicate-as ;
+
+: float-4-boa ( a b c d -- simd-array )
+ \ float-4 new 4sequence ;
+
+: double-2-with ( x -- simd-array )
+ [ 2 ] dip >float '[ _ ] \ double-2 new replicate-as ;
+
+: double-2-boa ( a b -- simd-array )
+ \ double-2 new 2sequence ;
+
+! More efficient expansions for the above, used when SIMD is
+! actually available.
+
+<<
+
+\ float-4-with [
+ drop
+ \ (simd-broadcast) "intrinsic" word-prop [
+ [ >float float-4-rep (simd-broadcast) \ float-4 boa ]
+ ] [ \ float-4-with def>> ] if
+] "custom-inlining" set-word-prop
+
+\ float-4-boa [
+ drop
+ \ (simd-gather-4) "intrinsic" word-prop [
+ [| a b c d |
+ a >float b >float c >float d >float
+ float-4-rep (simd-gather-4) \ float-4 boa
+ ]
+ ] [ \ float-4-boa def>> ] if
+] "custom-inlining" set-word-prop
+
+\ double-2-with [
+ drop
+ \ (simd-broadcast) "intrinsic" word-prop [
+ [ >float double-2-rep (simd-broadcast) \ double-2 boa ]
+ ] [ \ double-2-with def>> ] if
+] "custom-inlining" set-word-prop
+
+\ double-2-boa [
+ drop
+ \ (simd-gather-4) "intrinsic" word-prop [
+ [ [ >float ] bi@ double-2-rep (simd-gather-2) \ double-2 boa ]
+ ] [ \ double-2-boa def>> ] if
+] "custom-inlining" set-word-prop
+
+>>
+
+: float-8-with ( x -- simd-array )
+ [ float-4-with ] [ float-4-with ] bi [ underlying>> ] bi@
+ \ float-8 boa ; inline
+
+:: float-8-boa ( a b c d e f g h -- simd-array )
+ a b c d float-4-boa
+ e f g h float-4-boa
+ [ underlying>> ] bi@
+ \ float-8 boa ; inline
+
+: double-4-with ( x -- simd-array )
+ [ double-2-with ] [ double-2-with ] bi [ underlying>> ] bi@
+ \ double-4 boa ; inline
+
+:: double-4-boa ( a b c d -- simd-array )
+ a b double-2-boa
+ c d double-2-boa
+ [ underlying>> ] bi@
+ \ double-4 boa ; inline
+
+<<
+
+<PRIVATE
+
+! Filter out operations that are not available, eg horizontal adds
+! on SSE2. Fallback code in math.vectors is used in that case.
+
+: supported-simd-ops ( assoc -- assoc' )
+ {
+ { v+ (simd-v+) }
+ { v- (simd-v-) }
+ { v* (simd-v*) }
+ { v/ (simd-v/) }
+ { vmin (simd-vmin) }
+ { vmax (simd-vmax) }
+ { sum (simd-sum) }
+ } [ nip "intrinsic" word-prop ] assoc-filter
+ '[ drop _ key? ] assoc-filter ;
+
+! Some SIMD operations are defined in terms of others.
+
+:: high-level-ops ( ctor -- assoc )
+ {
+ { vneg [ [ dup v- ] keep v- ] }
+ { v. [ v* sum ] }
+ { n+v [ [ ctor execute ] dip v+ ] }
+ { v+n [ ctor execute v+ ] }
+ { n-v [ [ ctor execute ] dip v- ] }
+ { v-n [ ctor execute v- ] }
+ { n*v [ [ ctor execute ] dip v* ] }
+ { v*n [ ctor execute v* ] }
+ { n/v [ [ ctor execute ] dip v/ ] }
+ { v/n [ ctor execute v/ ] }
+ { norm-sq [ dup v. assert-positive ] }
+ { norm [ norm-sq sqrt ] }
+ { normalize [ dup norm v/n ] }
+ { distance [ v- norm ] }
+ } ;
+
+:: simd-vector-words ( class ctor elt-type assoc -- )
+ class elt-type assoc supported-simd-ops ctor high-level-ops assoc-union
+ specialize-vector-words ;
+
+PRIVATE>
+
+\ float-4 \ float-4-with float H{
+ { v+ [ [ (simd-v+) ] float-4-vv->v-op ] }
+ { v- [ [ (simd-v-) ] float-4-vv->v-op ] }
+ { v* [ [ (simd-v*) ] float-4-vv->v-op ] }
+ { v/ [ [ (simd-v/) ] float-4-vv->v-op ] }
+ { vmin [ [ (simd-vmin) ] float-4-vv->v-op ] }
+ { vmax [ [ (simd-vmax) ] float-4-vv->v-op ] }
+ { sum [ [ (simd-sum) ] float-4-v->n-op ] }
+} simd-vector-words
+
+\ double-2 \ double-2-with float H{
+ { v+ [ [ (simd-v+) ] double-2-vv->v-op ] }
+ { v- [ [ (simd-v-) ] double-2-vv->v-op ] }
+ { v* [ [ (simd-v*) ] double-2-vv->v-op ] }
+ { v/ [ [ (simd-v/) ] double-2-vv->v-op ] }
+ { vmin [ [ (simd-vmin) ] double-2-vv->v-op ] }
+ { vmax [ [ (simd-vmax) ] double-2-vv->v-op ] }
+ { sum [ [ (simd-sum) ] double-2-v->n-op ] }
+} simd-vector-words
+
+\ float-8 \ float-8-with float H{
+ { v+ [ [ (simd-v+) ] float-8-vv->v-op ] }
+ { v- [ [ (simd-v-) ] float-8-vv->v-op ] }
+ { v* [ [ (simd-v*) ] float-8-vv->v-op ] }
+ { v/ [ [ (simd-v/) ] float-8-vv->v-op ] }
+ { vmin [ [ (simd-vmin) ] float-8-vv->v-op ] }
+ { vmax [ [ (simd-vmax) ] float-8-vv->v-op ] }
+ { sum [ [ (simd-sum) ] [ + ] float-8-v->n-op ] }
+} simd-vector-words
+
+\ double-4 \ double-4-with float H{
+ { v+ [ [ (simd-v+) ] double-4-vv->v-op ] }
+ { v- [ [ (simd-v-) ] double-4-vv->v-op ] }
+ { v* [ [ (simd-v*) ] double-4-vv->v-op ] }
+ { v/ [ [ (simd-v/) ] double-4-vv->v-op ] }
+ { vmin [ [ (simd-vmin) ] double-4-vv->v-op ] }
+ { vmax [ [ (simd-vmax) ] double-4-vv->v-op ] }
+ { sum [ [ (simd-v+) ] [ (simd-sum) ] double-4-v->n-op ] }
+} simd-vector-words
+
+>>
+
+USE: vocabs.loader
+
+"math.vectors.simd.alien" require
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel make sequences effects kernel.private accessors
combinators math math.intervals math.vectors namespaces assocs fry
-splitting classes.algebra generalizations
+splitting classes.algebra generalizations locals
compiler.tree.propagation.info ;
IN: math.vectors.specialization
{ vmin { +vector+ +vector+ -> +vector+ } }
{ vneg { +vector+ -> +vector+ } }
{ vtruncate { +vector+ -> +vector+ } }
+ { sum { +vector+ -> +scalar+ } }
}
SYMBOL: specializations
: outputs ( schema -- seq ) { -> } split second ;
-: specialize-vector-word ( word array-type elt-type -- word' )
+: loop-vector-op ( word array-type elt-type -- word' )
pick word-schema
[ inputs (specialize-vector-word) ]
[ outputs record-output-signature ] 3bi ;
-: input-signature ( word -- signature ) def>> first ;
+:: specialize-vector-word ( word array-type elt-type simd -- word/quot' )
+ word simd key? [ word simd at ] [ word array-type elt-type loop-vector-op ] if ;
-: specialize-vector-words ( array-type elt-type -- )
- [ vector-words keys ] 2dip
- '[
- [ _ _ specialize-vector-word ] keep
- [ dup input-signature ] dip
- add-specialization
+:: input-signature ( word array-type elt-type -- signature )
+ array-type elt-type word word-schema inputs signature-for-schema ;
+
+:: specialize-vector-words ( array-type elt-type simd -- )
+ vector-words keys [
+ [ array-type elt-type simd specialize-vector-word ]
+ [ array-type elt-type input-signature ]
+ [ ]
+ tri add-specialization
] each ;
: find-specialization ( classes word -- word/f )
IN: math.vectors
ARTICLE: "math-vectors" "Vector arithmetic"
-"Any Factor sequence can be used to represent a mathematical vector."
+"Any Factor sequence can be used to represent a mathematical vector, however for best performance, the sequences defined by the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "math.vectors.simd" } " vocabularies should be used."
$nl
"Acting on vectors by a scalar:"
{ $subsection vneg }
{ $subsection n*v }
{ $subsection v/n }
{ $subsection n/v }
+{ $subsection v+n }
+{ $subsection n+v }
+{ $subsection v-n }
+{ $subsection n-v }
"Combining two vectors to form another vector with " { $link 2map } ":"
{ $subsection v+ }
{ $subsection v- }
+++ /dev/null
-USING: specialized-arrays.alien specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.alien
-
-<< "void*" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.bool specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.bool
-
-<< "bool" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.char specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.char
-
-<< "char" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.complex-double specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.complex-double
-
-<< "complex-double" define-direct-array >>
+++ /dev/null
-USING: specialized-arrays.complex-float specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.complex-float
-
-<< "complex-float" define-direct-array >>
+++ /dev/null
-USING: help.markup help.syntax byte-arrays alien ;
-IN: specialized-arrays.direct
-
-ARTICLE: "specialized-arrays.direct" "Direct-mapped specialized arrays"
-"The " { $vocab-link "specialized-arrays.direct" } " vocabulary implements fixed-length sequence types for storing machine values in unmanaged C memory."
-$nl
-"For each primitive C type " { $snippet "T" } ", a set of words are defined:"
-{ $table
- { { $snippet "direct-T-array" } { "The class of direct arrays with elements of type " { $snippet "T" } } }
- { { $snippet "<direct-T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( alien len -- array )" } } }
-}
-"Each direct array has a " { $slot "underlying" } " slot holding an " { $link simple-alien } " pointer to the raw data. This data can be passed to C functions."
-$nl
-"The primitive C types for which direct arrays exist:"
-{ $list
- { $snippet "char" }
- { $snippet "uchar" }
- { $snippet "short" }
- { $snippet "ushort" }
- { $snippet "int" }
- { $snippet "uint" }
- { $snippet "long" }
- { $snippet "ulong" }
- { $snippet "longlong" }
- { $snippet "ulonglong" }
- { $snippet "float" }
- { $snippet "double" }
- { $snippet "void*" }
- { $snippet "bool" }
-}
-"Direct arrays are generated with a functor in the " { $vocab-link "specialized-arrays.direct.functor" } " vocabulary." ;
-
-ABOUT: "specialized-arrays.direct"
+++ /dev/null
-IN: specialized-arrays.direct.tests
-USING: specialized-arrays.direct.ushort tools.test
-specialized-arrays.ushort alien.syntax sequences ;
-
-[ ushort-array{ 0 0 0 } ] [
- 3 ALIEN: 123 100 <direct-ushort-array> new-sequence
-] unit-test
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: specialized-arrays.direct
+++ /dev/null
-USING: specialized-arrays.double specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.double
-
-<< "double" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.float specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.float
-
-<< "float" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: functors sequences sequences.private kernel words classes
-math alien alien.c-types byte-arrays accessors
-specialized-arrays parser
-prettyprint.backend prettyprint.custom prettyprint.sections ;
-IN: specialized-arrays.direct.functor
-
-<PRIVATE
-
-: pprint-direct-array ( direct-array tag -- )
- [ [ underlying>> ] [ length>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
-
-PRIVATE>
-
-FUNCTOR: define-direct-array ( T -- )
-
-A' IS ${T}-array
-S IS ${T}-sequence
->A' IS >${T}-array
-<A'> IS <${A'}>
-A'{ IS ${A'}{
-
-A DEFINES-CLASS direct-${T}-array
-<A> DEFINES <${A}>
-A'@ DEFINES ${A'}@
-
-NTH [ T dup c-type-getter-boxer array-accessor ]
-SET-NTH [ T dup c-setter array-accessor ]
-
-WHERE
-
-TUPLE: A
-{ underlying c-ptr read-only }
-{ length fixnum read-only } ;
-
-: <A> ( alien len -- direct-array ) A boa ; inline
-M: A length length>> ; inline
-M: A nth-unsafe underlying>> NTH call ; inline
-M: A set-nth-unsafe underlying>> SET-NTH call ; inline
-M: A like drop dup A instance? [ >A' ] unless ; inline
-M: A new-sequence drop <A'> ; inline
-
-M: A byte-length length>> T heap-size * ; inline
-
-SYNTAX: A'@
- scan-object scan-object <A> parsed ;
-
-M: A pprint-delims drop \ A'{ \ } ;
-
-M: A >pprint-sequence ;
-
-M: A pprint*
- [ pprint-object ]
- [ \ A'@ pprint-direct-array ]
- pprint-c-object ;
-
-INSTANCE: A sequence
-INSTANCE: A S
-
-T c-type
- \ A >>direct-array-class
- \ <A> >>direct-array-constructor
- drop
-
-;FUNCTOR
+++ /dev/null
-Code generation for direct specialized arrays
+++ /dev/null
-USING: specialized-arrays.int specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.int
-
-<< "int" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.long specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.long
-
-<< "long" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.longlong specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.longlong
-
-<< "longlong" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.short specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.short
-
-<< "short" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.uchar specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.uchar
-
-<< "uchar" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.uint specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.uint
-
-<< "uint" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.ulong specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.ulong
-
-<< "ulong" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.ulonglong specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.ulonglong
-
-<< "ulonglong" define-direct-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-arrays.ushort specialized-arrays.direct.functor ;
-IN: specialized-arrays.direct.ushort
-
-<< "ushort" define-direct-array >>
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private prettyprint.custom
kernel words classes math math.vectors.specialization parser
-alien.c-types byte-arrays accessors summary ;
+alien.c-types byte-arrays accessors summary alien specialized-arrays ;
IN: specialized-arrays.functor
ERROR: bad-byte-array-length byte-array type ;
S DEFINES-CLASS ${T}-sequence
<A> DEFINES <${A}>
(A) DEFINES (${A})
+<direct-A> DEFINES <direct-${A}>
>A DEFINES >${A}
byte-array>A DEFINES byte-array>${A}
+
A{ DEFINES ${A}{
+A@ DEFINES ${A}@
NTH [ T dup c-type-getter-boxer array-accessor ]
SET-NTH [ T dup c-setter array-accessor ]
MIXIN: S
TUPLE: A
-{ length array-capacity read-only }
-{ underlying byte-array read-only } ;
+{ underlying c-ptr read-only }
+{ length array-capacity read-only } ;
+
+: <direct-A> ( alien len -- specialized-array ) A boa ; inline
-: <A> ( n -- specialized-array ) dup T <underlying> A boa ; inline
+: <A> ( n -- specialized-array ) [ T <underlying> ] keep <direct-A> ; inline
-: (A) ( n -- specialized-array ) dup T (underlying) A boa ; inline
+: (A) ( n -- specialized-array ) [ T (underlying) ] keep <direct-A> ; inline
: byte-array>A ( byte-array -- specialized-array )
dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
- swap A boa ; inline
+ <direct-A> ; inline
-M: A clone [ length>> ] [ underlying>> clone ] bi A boa ; inline
+M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline
M: A length length>> ; inline
M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
M: A resize
- [ drop ] [
+ [
[ T heap-size * ] [ underlying>> ] bi*
resize-byte-array
- ] 2bi
- A boa ; inline
+ ] [ drop ] 2bi
+ <direct-A> ; inline
M: A byte-length underlying>> length ; inline
-
M: A pprint-delims drop \ A{ \ } ;
-
M: A >pprint-sequence ;
-M: A pprint* pprint-object ;
-
SYNTAX: A{ \ } [ >A ] parse-literal ;
+SYNTAX: A@ scan-object scan-object <direct-A> parsed ;
-INSTANCE: A sequence
-INSTANCE: A S
+INSTANCE: A specialized-array
-A T c-type-boxed-class specialize-vector-words
+A T c-type-boxed-class f specialize-vector-words
T c-type
\ A >>array-class
\ <A> >>array-constructor
\ (A) >>(array)-constructor
- \ S >>sequence-mixin-class
+ \ <direct-A> >>direct-array-constructor
drop
;FUNCTOR
--- /dev/null
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel prettyprint.backend
+prettyprint.sections prettyprint.custom
+specialized-arrays ;
+IN: specialized-arrays.prettyprint
+
+: pprint-direct-array ( direct-array -- )
+ dup direct-array-syntax
+ [ [ underlying>> ] [ length>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
+
+M: specialized-array pprint*
+ [ pprint-object ] [ pprint-direct-array ] pprint-c-object ;
+
{ $table
{ { $snippet "T-array" } { "The class of arrays with elements of type " { $snippet "T" } } }
{ { $snippet "<T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( len -- array )" } } }
- { { $snippet ">T-array" } { "Converts a sequence into a specialized array of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- array )" } } }
+ { { $snippet "<direct-T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( alien len -- array )" } } }
{ { $snippet "byte-array>T-array" } { "Converts a byte array into a specialized array by interpreting the bytes in as machine-specific values. Code which uses this word is unportable" } }
+ { { $snippet ">T-array" } { "Converts a sequence into a specialized array of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- array )" } } }
{ { $snippet "T-array{" } { "Literal syntax, consists of a series of values terminated by " { $snippet "}" } } }
}
"Each specialized array has a " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. This data can be passed to C functions."
IN: specialized-arrays.tests
-USING: tools.test specialized-arrays sequences
+USING: tools.test alien.syntax specialized-arrays sequences
specialized-arrays.int specialized-arrays.bool
specialized-arrays.ushort alien.c-types accessors kernel
-specialized-arrays.direct.int specialized-arrays.char
-specialized-arrays.uint arrays combinators ;
+specialized-arrays.char specialized-arrays.uint arrays combinators ;
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
[ { 3 1 3 3 7 } ] [
int-array{ 3 1 3 3 7 } malloc-byte-array 5 <direct-int-array> >array
-] unit-test
\ No newline at end of file
+] unit-test
+
+[ f ] [ float-array{ 4 3 2 1 } dup clone [ underlying>> ] bi@ eq? ] unit-test
+
+[ f ] [ [ float-array{ 4 3 2 1 } dup clone [ underlying>> ] bi@ eq? ] compile-call ] unit-test
+
+[ ushort-array{ 0 0 0 } ] [
+ 3 ALIEN: 123 100 <direct-ushort-array> new-sequence
+ dup [ drop 0 ] change-each
+] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences vocabs vocabs.loader ;
IN: specialized-arrays
+
+MIXIN: specialized-array
+INSTANCE: specialized-array sequence
+
+GENERIC: direct-array-syntax ( obj -- word )
+
+"prettyprint" vocab [
+ "specialized-arrays.prettyprint" require
+] when
IN: struct-arrays.tests
USING: classes.struct struct-arrays tools.test kernel math sequences
-alien.syntax alien.c-types destructors libc accessors sequences.private ;
+alien.syntax alien.c-types destructors libc accessors sequences.private
+compiler.tree.debugger combinators.smart ;
STRUCT: test-struct-array
{ x int }
{ y int } ;
+[ 1 ] [
+ 1 struct-array{ test-struct-array } new-sequence length
+] unit-test
+
+[ V{ test-struct-array } ] [
+ [ [ test-struct-array <struct> ] struct-array{ test-struct-array } output>sequence first ] final-classes
+] unit-test
+
: make-point ( x y -- struct )
test-struct-array <struct-boa> ;
ALIEN: 123 4 fixed-string <direct-struct-array> [ (underlying)>> ] { } map-as
] unit-test
-[ 10 "int" <struct-array> ] must-fail
\ No newline at end of file
+[ 10 "int" <struct-array> ] must-fail
+
+STRUCT: wig { x int } ;
+: <bacon> ( -- wig ) 0 wig <struct-boa> ; inline
+: waterfall ( -- a b ) 1 wig <struct-array> <bacon> swap first x>> ; inline
+
+[ t ] [ [ waterfall ] { x>> } inlined? ] unit-test
\ No newline at end of file
tri struct-array boa ; inline
M: struct-array new-sequence
- [ element-size>> * (byte-array) ] [ length>> ] [ class>> ] tri
+ [ element-size>> * (byte-array) ] [ class>> ] 2bi
<direct-struct-array> ; inline
M: struct-array resize ( n seq -- newseq )
\r
os windows? os macosx? or [\r
[ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test\r
+] when\r
+\r
+os macosx? [\r
+ [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test\r
] when
\ No newline at end of file
"slots"
"special"
"specializer"
+ "struct-slots"
! UI needs this
! "superclass"
"transform-n"
-USING: kernel stack-checker.transforms struct-arrays.private ;
-IN: struct-arrays
+USING: kernel stack-checker.transforms ;
+IN: struct-arrays.private
: struct-element-constructor ( c-type -- word )
"Struct array usages must be compiled" throw ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors classes.struct cocoa cocoa.classes
+cocoa.subclassing core-graphics.types kernel math ;
+IN: tools.deploy.test.14
+
+CLASS: {
+ { +superclass+ "NSObject" }
+ { +name+ "Bar" }
+} {
+ "bar:"
+ "float"
+ { "id" "SEL" "NSRect" }
+ [
+ [ origin>> [ x>> ] [ y>> ] bi + ]
+ [ size>> [ w>> ] [ h>> ] bi + ]
+ bi +
+ ]
+} ;
+
+: main ( -- )
+ Bar -> alloc -> init
+ S{ CGRect f S{ CGPoint f 1.0 2.0 } S{ CGSize f 3.0 4.0 } } -> bar:
+ 10.0 assert= ;
+
+MAIN: main
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-math? t }
+ { deploy-io 2 }
+ { deploy-c-types? f }
+ { deploy-reflection 1 }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-word-props? f }
+ { deploy-threads? t }
+ { deploy-ui? f }
+ { deploy-unicode? f }
+ { deploy-name "tools.deploy.test.14" }
+}
--- /dev/null
+unportable
handle>> window>> swap
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
-M: x11-ui-backend (set-fullscreen) ( world ? -- )
+: make-fullscreen-msg ( world ? -- msg )
XClientMessageEvent <struct>
- swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
- swap handle>> window>> >>window
+ ClientMessage >>type
dpy get >>display
"_NET_WM_STATE" x-atom >>message_type
+ swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? >>data0
+ swap handle>> window>> >>window
32 >>format
- "_NET_WM_STATE_FULLSCREEN" x-atom >>data1
- [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
+ "_NET_WM_STATE_FULLSCREEN" x-atom >>data1 ;
+
+M: x11-ui-backend (set-fullscreen) ( world ? -- )
+ [ dpy get root get 0 SubstructureNotifyMask ] 2dip
+ make-fullscreen-msg XSendEvent drop ;
M: x11-ui-backend (open-window) ( world -- )
dup gadget-window
CONSTANT: F_SETFL 4
CONSTANT: FD_CLOEXEC 1
-C-STRUCT: sockaddr-in
- { "uchar" "len" }
- { "uchar" "family" }
- { "ushort" "port" }
- { "in_addr_t" "addr" }
- { "longlong" "unused" } ;
-
-C-STRUCT: sockaddr-in6
- { "uchar" "len" }
- { "uchar" "family" }
- { "ushort" "port" }
- { "uint" "flowinfo" }
- { { "uchar" 16 } "addr" }
- { "uint" "scopeid" } ;
-
-C-STRUCT: sockaddr-un
- { "uchar" "len" }
- { "uchar" "family" }
- { { "char" 104 } "path" } ;
+STRUCT: sockaddr-in
+ { len uchar }
+ { family uchar }
+ { port ushort }
+ { addr in_addr_t }
+ { unused longlong } ;
+
+STRUCT: sockaddr-in6
+ { len uchar }
+ { family uchar }
+ { port ushort }
+ { flowinfo uint }
+ { addr uchar[16] }
+ { scopeid uint } ;
+
+STRUCT: sockaddr-un
+ { len uchar }
+ { family uchar }
+ { path char[104] } ;
STRUCT: passwd
{ pw_name char* }
CONSTANT: FD_SETSIZE 1024
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "char*" "canonname" }
- { "void*" "addr" }
- { "addrinfo*" "next" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { canonname char* }
+ { addr void* }
+ { next addrinfo* } ;
STRUCT: dirent
{ d_fileno u_int32_t }
CONSTANT: FD_SETSIZE 1024
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "char*" "canonname" }
- { "void*" "addr" }
- { "addrinfo*" "next" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { canonname char* }
+ { addr void* }
+ { next addrinfo* } ;
CONSTANT: _UTX_USERSIZE 256
CONSTANT: _UTX_LINESIZE 32
CONSTANT: FD_SETSIZE 256
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "char*" "canonname" }
- { "void*" "addr" }
- { "addrinfo*" "next" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { canonname char* }
+ { addr void* }
+ { next addrinfo* } ;
STRUCT: dirent
{ d_fileno __uint32_t }
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.time ;
+USING: alien.syntax unix.time classes.struct ;
IN: unix
-C-STRUCT: sockaddr_storage
- { "__uint8_t" "ss_len" }
- { "sa_family_t" "ss_family" }
- { { "char" _SS_PAD1SIZE } "__ss_pad1" }
- { "__int64_t" "__ss_align" }
- { { "char" _SS_PAD2SIZE } "__ss_pad2" } ;
+STRUCT: sockaddr_storage
+ { ss_len __uint8_t }
+ { ss_family sa_family_t }
+ { __ss_pad1 { "char" _SS_PAD1SIZE } }
+ { __ss_align __int64_t }
+ { __ss_pad2 { "char" _SS_PAD2SIZE } } ;
-C-STRUCT: exit_struct
- { "uint16_t" "e_termination" }
- { "uint16_t" "e_exit" } ;
+STRUCT: exit_struct
+ { e_termination uint16_t }
+ { e_exit uint16_t } ;
C-STRUCT: utmpx
{ { "char" _UTX_USERSIZE } "ut_user" }
CONSTANT: FD_SETSIZE 1024
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "void*" "addr" }
- { "char*" "canonname" }
- { "addrinfo*" "next" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { addr void* }
+ { canonname char* }
+ { next addrinfo* } ;
STRUCT: dirent
{ d_fileno __uint32_t }
CONSTANT: F_SETFL 4
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "socklen_t" "addrlen" }
- { "void*" "addr" }
- { "char*" "canonname" }
- { "addrinfo*" "next" } ;
-
-C-STRUCT: sockaddr-in
- { "ushort" "family" }
- { "ushort" "port" }
- { "in_addr_t" "addr" }
- { "longlong" "unused" } ;
-
-C-STRUCT: sockaddr-in6
- { "ushort" "family" }
- { "ushort" "port" }
- { "uint" "flowinfo" }
- { { "uchar" 16 } "addr" }
- { "uint" "scopeid" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen socklen_t }
+ { addr void* }
+ { canonname char* }
+ { next addrinfo* } ;
+
+STRUCT: sockaddr-in
+ { family ushort }
+ { port ushort }
+ { addr in_addr_t }
+ { unused longlong } ;
+
+STRUCT: sockaddr-in6
+ { family ushort }
+ { port ushort }
+ { flowinfo uint }
+ { addr uchar[16] }
+ { scopeid uint } ;
CONSTANT: max-un-path 108
-C-STRUCT: sockaddr-un
- { "ushort" "family" }
- { { "char" max-un-path } "path" } ;
+STRUCT: sockaddr-un
+ { family ushort }
+ { path { "char" max-un-path } } ;
CONSTANT: SOCK_STREAM 1
CONSTANT: SOCK_DGRAM 2
! Copyright (C) 2006 Patrick Mauritz.
! See http://factorcode.org/license.txt for BSD license.
-IN: unix
USING: alien.syntax system kernel layouts ;
+IN: unix
! Solaris.
CONSTANT: F_SETFL 4 ! set file status flags
CONSTANT: O_NONBLOCK HEX: 80 ! no delay
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
! #ifdef __sparcv9
! int _ai_pad;
! #endif
- { "int" "addrlen" }
- { "char*" "canonname" }
- { "void*" "addr" }
- { "void*" "next" } ;
-
-C-STRUCT: sockaddr-in
- { "ushort" "family" }
- { "ushort" "port" }
- { "in_addr_t" "addr" }
- { "longlong" "unused" } ;
-
-C-STRUCT: sockaddr-in6
- { "ushort" "family" }
- { "ushort" "port" }
- { "uint" "flowinfo" }
- { { "uchar" 16 } "addr" }
- { "uint" "scopeid" } ;
+ { addrlen int }
+ { canonname char* }
+ { addr void* }
+ { next void* } ;
+
+STRUCT: sockaddr-in
+ { family ushort }
+ { port ushort }
+ { addr in_addr_t }
+ { unused longlong } ;
+
+STRUCT: sockaddr-in6
+ { family ushort }
+ { port ushort }
+ { flowinfo uint }
+ { addr uchar[16] }
+ { scopeid uint } ;
: max-un-path 108 ;
-C-STRUCT: sockaddr-un
- { "ushort" "family" }
- { { "char" max-un-path } "path" } ;
+STRUCT: sockaddr-un
+ { family ushort }
+ { path { "char" max-un-path } } ;
CONSTANT: EINTR 4
CONSTANT: EAGAIN 11
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: windows.com windows.kernel32 windows.ole32
+prettyprint.custom prettyprint.sections sequences ;
+IN: windows.com.prettyprint
+
+M: GUID pprint* guid>string "GUID: " prepend text ;
--- /dev/null
+unportable
windows.ole32 parser lexer splitting grouping sequences
namespaces assocs quotations generalizations accessors words
macros alien.syntax fry arrays layouts math classes.struct
-windows.kernel32 prettyprint.custom prettyprint.sections ;
+windows.kernel32 ;
IN: windows.com.syntax
<PRIVATE
SYNTAX: GUID: scan string>guid parsed ;
-M: GUID pprint* guid>string "GUID: " prepend text ;
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [
+ "windows.com.prettyprint" require
+] when
namespaces windows.ole32 libc vocabs assocs accessors arrays
sequences quotations combinators math words compiler.units
destructors fry math.parser generalizations sets
-specialized-arrays.alien specialized-arrays.direct.alien
-windows.kernel32 classes.struct ;
+specialized-arrays.alien windows.kernel32 classes.struct ;
IN: windows.com.wrapper
TUPLE: com-wrapper < disposable callbacks vtbls ;
alien.c-types alien sequences math ;\r
IN: windows.dragdrop-listener\r
\r
-<< "WCHAR" require-c-arrays >>\r
+<< "WCHAR" require-c-array >>\r
\r
: filenames-from-hdrop ( hdrop -- filenames )\r
dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files\r
arrays literals ;
IN: windows.errors
-<< "TCHAR" require-c-arrays >>
+<< "TCHAR" require-c-array >>
CONSTANT: ERROR_SUCCESS 0
CONSTANT: ERROR_INVALID_FUNCTION 1
: make-lang-id ( lang1 lang2 -- n )
10 shift bitor ; inline
-<< "TCHAR" require-c-arrays >>
+<< "TCHAR" require-c-array >>
ERROR: error-message-failed id ;
:: n>win32-error-string ( id -- string )
TYPEDEF: uint COMPUTER_NAME_FORMAT
-C-STRUCT: OVERLAPPED
- { "UINT_PTR" "internal" }
- { "UINT_PTR" "internal-high" }
- { "DWORD" "offset" }
- { "DWORD" "offset-high" }
- { "HANDLE" "event" } ;
+STRUCT: OVERLAPPED
+ { internal UINT_PTR }
+ { internal-high UINT_PTR }
+ { offset DWORD }
+ { offset-high DWORD }
+ { event HANDLE } ;
STRUCT: SYSTEMTIME
{ wYear WORD }
USING: alien alien.syntax alien.c-types alien.strings math
kernel sequences windows.errors windows.types io
accessors math.order namespaces make math.parser windows.kernel32
-combinators locals specialized-arrays.direct.uchar
+combinators locals specialized-arrays.uchar
literals splitting grouping classes.struct combinators.smart ;
IN: windows.ole32
! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax arrays
-byte-arrays kernel math sequences windows.types windows.kernel32
-windows.errors math.bitwise io.encodings.utf16n classes.struct
-literals windows.com.syntax ;
+byte-arrays kernel literals math sequences windows.types
+windows.kernel32 windows.errors math.bitwise io.encodings.utf16n
+classes.struct windows.com.syntax init ;
IN: windows.winsock
-USE: libc
-: alien>byte-array ( alien str -- byte-array )
- heap-size dup <byte-array> [ -rot memcpy ] keep ;
-
TYPEDEF: void* SOCKET
: <wsadata> ( -- byte-array )
CONSTANT: AI_PASSIVE 1
CONSTANT: AI_CANONNAME 2
CONSTANT: AI_NUMERICHOST 4
-: AI_MASK ( -- n ) { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ;
+
+: AI_MASK ( -- n )
+ { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ; inline
CONSTANT: NI_NUMERICHOST 1
CONSTANT: NI_NUMERICSERV 2
CONSTANT: INADDR_ANY 0
-: INVALID_SOCKET ( -- alien ) -1 <alien> ; inline
+: INVALID_SOCKET ( -- n ) -1 <alien> ; inline
+
CONSTANT: SOCKET_ERROR -1
CONSTANT: SD_RECV 0
CONSTANT: SOL_SOCKET HEX: ffff
-! TYPEDEF: uint in_addr_t
-! C-STRUCT: in_addr
- ! { "in_addr_t" "s_addr" } ;
+STRUCT: sockaddr-in
+ { family short }
+ { port ushort }
+ { addr uint }
+ { pad char[8] } ;
-C-STRUCT: sockaddr-in
- { "short" "family" }
- { "ushort" "port" }
- { "uint" "addr" }
- { { "char" 8 } "pad" } ;
-
-C-STRUCT: sockaddr-in6
- { "uchar" "family" }
- { "ushort" "port" }
- { "uint" "flowinfo" }
- { { "uchar" 16 } "addr" }
- { "uint" "scopeid" } ;
+STRUCT: sockaddr-in6
+ { family uchar }
+ { port ushort }
+ { flowinfo uint }
+ { addr uchar[16] }
+ { scopeid uint } ;
STRUCT: hostent
{ name char* }
{ length short }
{ addr-list void* } ;
-C-STRUCT: addrinfo
- { "int" "flags" }
- { "int" "family" }
- { "int" "socktype" }
- { "int" "protocol" }
- { "size_t" "addrlen" }
- { "char*" "canonname" }
- { "sockaddr*" "addr" }
- { "addrinfo*" "next" } ;
+STRUCT: addrinfo
+ { flags int }
+ { family int }
+ { socktype int }
+ { protocol int }
+ { addrlen size_t }
+ { canonname char* }
+ { addr sockaddr* }
+ { next addrinfo* } ;
C-STRUCT: timeval
{ "long" "sec" }
! Not in Windows CE
FUNCTION: int AcceptEx ( void* listen, void* accept, void* out-buf, int recv-len, int addr-len, int remote-len, void* out-len, void* overlapped ) ;
-FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, void* f, void* g, void* h ) ;
+
+FUNCTION: void GetAcceptExSockaddrs (
+ PVOID lpOutputBuffer,
+ DWORD dwReceiveDataLength,
+ DWORD dwLocalAddressLength,
+ DWORD dwRemoteAddressLength,
+ LPSOCKADDR* LocalSockaddr,
+ LPINT LocalSockaddrLength,
+ LPSOCKADDR* RemoteSockaddr,
+ LPINT RemoteSockaddrLength
+) ;
CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
: init-winsock ( -- )
HEX: 0202 <wsadata> WSAStartup winsock-return-check ;
+
+[ init-winsock ] "windows.winsock" add-init-hook
slots>tuple ;
: outdated-tuple? ( tuple assoc -- ? )
- over tuple? [
- [ [ layout-of ] dip key? ]
- [ drop class "forgotten" word-prop not ]
- 2bi and
- ] [ 2drop f ] if ;
+ [ [ layout-of ] dip key? ]
+ [ drop class "forgotten" word-prop not ]
+ 2bi and ;
: update-tuples ( -- )
outdated-tuples get
dup assoc-empty? [ drop ] [
- [ outdated-tuple? ] curry instances
+ [ [ tuple? ] instances ] dip [ outdated-tuple? ] curry filter
dup [ update-tuple ] map become
] if ;
"and"
{ $code "[ [ reverse % ] each ] \"\" make" }
"is equivalent to"
-{ $code "[ [ reverse ] map concat" }
+{ $code "[ reverse ] map concat" }
{ $heading "Utilities for simple make patterns" }
"Sometimes, an existing word already implements a specific " { $link make } " usage. For example, " { $link suffix } " is equivalent to the following, with the added caveat that the below example always outputs an array:"
{ $code "[ , % ] { } make" }
HELP: %
{ $values { "seq" sequence } }
-{ $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ;
\ No newline at end of file
+{ $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ;
[ -0.0 ] [ 0.0 prev-float ] unit-test
[ t ] [ 1.0 dup prev-float > ] unit-test
[ t ] [ -1.0 dup prev-float > ] unit-test
+
+[ f ] [ 0/0. 0/0. = ] unit-test
+[ f ] [ 0/0. 1.0 = ] unit-test
+[ f ] [ 0/0. 1/0. = ] unit-test
+[ f ] [ 0/0. -1/0. = ] unit-test
+
+[ f ] [ 0/0. 0/0. = ] unit-test
+[ f ] [ 1.0 0/0. = ] unit-test
+[ f ] [ -1/0. 0/0. = ] unit-test
+[ f ] [ 1/0. 0/0. = ] unit-test
+
+[ f ] [ 0/0. 0/0. < ] unit-test
+[ f ] [ 0/0. 1.0 < ] unit-test
+[ f ] [ 0/0. 1/0. < ] unit-test
+[ f ] [ 0/0. -1/0. < ] unit-test
+
+[ f ] [ 0/0. 0/0. <= ] unit-test
+[ f ] [ 0/0. 1.0 <= ] unit-test
+[ f ] [ 0/0. 1/0. <= ] unit-test
+[ f ] [ 0/0. -1/0. <= ] unit-test
+
+[ f ] [ 0/0. 0/0. > ] unit-test
+[ f ] [ 1.0 0/0. > ] unit-test
+[ f ] [ -1/0. 0/0. > ] unit-test
+[ f ] [ 1/0. 0/0. > ] unit-test
+
+[ f ] [ 0/0. 0/0. >= ] unit-test
+[ f ] [ 1.0 0/0. >= ] unit-test
+[ f ] [ -1/0. 0/0. >= ] unit-test
+[ f ] [ 1/0. 0/0. >= ] unit-test
+
+
HELP: accumulate
{ $values { "identity" object } { "seq" sequence } { "quot" { $quotation "( prev elt -- next )" } } { "final" "the final result" } { "newseq" "a new sequence" } }
-{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. On the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the sequence."
+{ $description "Combines successive elements of the sequence using a binary operation, and outputs a sequence of intermediate results together with the final result. The first element of the new sequence is " { $snippet "identity" } ". Then, on the first iteration, the two inputs to the quotation are " { $snippet "identity" } ", and the first element of the old sequence. On successive iterations, the first input is the result of the previous iteration, and the second input is the corresponding element of the old sequence."
$nl
"When given the empty sequence, outputs an empty sequence together with the " { $snippet "identity" } "." }
{ $examples
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors fry kernel locals math math.constants
+math.functions math.vectors math.vectors.simd prettyprint
+combinators.smart sequences hints struct-arrays classes.struct ;
+IN: benchmark.nbody-simd
+
+: solar-mass ( -- x ) 4 pi sq * ; inline
+CONSTANT: days-per-year 365.24
+
+STRUCT: body
+{ location double-4 }
+{ velocity double-4 }
+{ mass double } ;
+
+: <body> ( location velocity mass -- body )
+ [ days-per-year v*n ] [ solar-mass * ] bi* body <struct-boa> ; inline
+
+: <jupiter> ( -- body )
+ double-4{ 4.84143144246472090e+00 -1.16032004402742839e+00 -1.03622044471123109e-01 0.0 }
+ double-4{ 1.66007664274403694e-03 7.69901118419740425e-03 -6.90460016972063023e-05 0.0 }
+ 9.54791938424326609e-04
+ <body> ;
+
+: <saturn> ( -- body )
+ double-4{ 8.34336671824457987e+00 4.12479856412430479e+00 -4.03523417114321381e-01 0.0 }
+ double-4{ -2.76742510726862411e-03 4.99852801234917238e-03 2.30417297573763929e-05 0.0 }
+ 2.85885980666130812e-04
+ <body> ;
+
+: <uranus> ( -- body )
+ double-4{ 1.28943695621391310e+01 -1.51111514016986312e+01 -2.23307578892655734e-01 0.0 }
+ double-4{ 2.96460137564761618e-03 2.37847173959480950e-03 -2.96589568540237556e-05 0.0 }
+ 4.36624404335156298e-05
+ <body> ;
+
+: <neptune> ( -- body )
+ double-4{ 1.53796971148509165e+01 -2.59193146099879641e+01 1.79258772950371181e-01 0.0 }
+ double-4{ 2.68067772490389322e-03 1.62824170038242295e-03 -9.51592254519715870e-05 0.0 }
+ 5.15138902046611451e-05
+ <body> ;
+
+: <sun> ( -- body )
+ double-4{ 0 0 0 0 } double-4{ 0 0 0 0 } 1 <body> ;
+
+: offset-momentum ( body offset -- body )
+ vneg solar-mass v/n >>velocity ; inline
+
+TUPLE: nbody-system { bodies struct-array read-only } ;
+
+: init-bodies ( bodies -- )
+ [ first ] [ [ [ velocity>> ] [ mass>> ] bi v*n ] [ v+ ] map-reduce ] bi
+ offset-momentum drop ; inline
+
+: <nbody-system> ( -- system )
+ [ <sun> <jupiter> <saturn> <uranus> <neptune> ]
+ struct-array{ body } output>sequence nbody-system boa
+ dup bodies>> init-bodies ; inline
+
+:: each-pair ( bodies pair-quot: ( other-body body -- ) each-quot: ( body -- ) -- )
+ bodies [| body i |
+ body each-quot call
+ bodies i 1 + tail-slice [
+ body pair-quot call
+ ] each
+ ] each-index ; inline
+
+: update-position ( body dt -- )
+ [ dup velocity>> ] dip '[ _ _ v*n v+ ] change-location drop ; inline
+
+: mag ( dt body other-body -- mag d )
+ [ location>> ] bi@ v- [ norm-sq dup sqrt * / ] keep ; inline
+
+:: update-velocity ( other-body body dt -- )
+ dt body other-body mag
+ [ [ body ] 2dip '[ other-body mass>> _ * _ n*v v- ] change-velocity drop ]
+ [ [ other-body ] 2dip '[ body mass>> _ * _ n*v v+ ] change-velocity drop ] 2bi ; inline
+
+: advance ( system dt -- )
+ [ bodies>> ] dip
+ [ '[ _ update-velocity ] [ drop ] each-pair ]
+ [ '[ _ update-position ] each ]
+ 2bi ; inline
+
+: inertia ( body -- e )
+ [ mass>> ] [ velocity>> norm-sq ] bi * 0.5 * ; inline
+
+: newton's-law ( other-body body -- e )
+ [ [ mass>> ] bi@ * ] [ [ location>> ] bi@ distance ] 2bi / ; inline
+
+: energy ( system -- x )
+ [ 0.0 ] dip bodies>> [ newton's-law - ] [ inertia + ] each-pair ; inline
+
+: nbody ( n -- )
+ >fixnum
+ <nbody-system>
+ [ energy . ] [ '[ _ 0.01 advance ] times ] [ energy . ] tri ;
+
+: nbody-main ( -- ) 1000000 nbody ;
+
+MAIN: nbody-main
! http://www.ffconsultancy.com/free/ray_tracer/languages.html
USING: arrays accessors specialized-arrays.double io io.files
-io.files.temp io.encodings.binary kernel math math.functions
-math.vectors math.parser make sequences sequences.private words
-hints ;
+io.files.temp io.encodings.binary kernel math math.constants
+math.functions math.vectors math.parser make sequences
+sequences.private words hints ;
IN: benchmark.raytracer
! parameters
CONSTANT: size 200
-CONSTANT: delta 1.4901161193847656E-8
+: delta ( -- n ) epsilon sqrt ; inline
TUPLE: ray { orig double-array read-only } { dir double-array read-only } ;
! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types alien.syntax kernel math math.order
-specialized-arrays.direct.functor specialized-arrays.functor ;
+specialized-arrays.functor ;
IN: half-floats
: half>bits ( float -- bits )
drop
"half" define-array
-"half" define-direct-array
>>
! Copyright (C) 2009 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors grouping sequences combinators
-math specialized-arrays.direct.uint byte-arrays fry
-specialized-arrays.direct.ushort specialized-arrays.uint
-specialized-arrays.ushort specialized-arrays.float images
-half-floats ;
+USING: kernel accessors grouping sequences combinators math
+byte-arrays fry specialized-arrays.uint specialized-arrays.ushort
+specialized-arrays.float images half-floats ;
IN: images.normalization
<PRIVATE
combinators ;
IN: opengl.glu
+<<
+
os {
{ [ dup macosx? ] [ drop ] }
{ [ dup windows? ] [ drop ] }
{ [ dup unix? ] [ drop "glu" "libGLU.so.1" "cdecl" add-library ] }
} cond
+>>
+
LIBRARY: glu
! These are defined as structs in glu.h, but we only ever use pointers to them
--- /dev/null
+USING: project-euler.085 tools.test ;
+IN: project-euler.085.tests
+
+[ 2772 ] [ euler085 ] unit-test
--- /dev/null
+! Copyright (c) 2009 Guillaume Nargeot.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math math.ranges project-euler.common sequences ;
+IN: project-euler.085
+
+! http://projecteuler.net/index.php?section=problems&id=85
+
+! DESCRIPTION
+! -----------
+
+! By counting carefully it can be seen that a rectangular grid measuring
+! 3 by 2 contains eighteen rectangles.
+
+! Although there exists no rectangular grid that contains exactly two million
+! rectangles, find the area of the grid with the nearest solution.
+
+
+! SOLUTION
+! --------
+
+! A grid measuring x by y contains x * (x + 1) * y * (x + 1) rectangles.
+
+<PRIVATE
+
+: distance ( m -- n )
+ 2000000 - abs ;
+
+: rectangles-count ( a b -- n )
+ 2dup [ 1 + ] bi@ * * * 4 / ;
+
+: unique-products ( a b -- seq )
+ tuck [a,b] [
+ over dupd [a,b] [ 2array ] with map
+ ] map concat nip ;
+
+: max-by-last ( seq seq -- seq )
+ [ [ last ] bi@ < ] most ;
+
+: array2 ( seq -- a b )
+ [ first ] [ last ] bi ;
+
+: convert ( seq -- seq )
+ array2 [ * ] [ rectangles-count distance ] 2bi 2array ;
+
+: area-of-nearest ( -- n )
+ 1 2000 unique-products
+ [ convert ] [ max-by-last ] map-reduce first ;
+
+PRIVATE>
+
+: euler085 ( -- answer )
+ area-of-nearest ;
+
+! [ euler085 ] 100 ave-time
+! 2285 ms ave run time - 4.8 SD (100 trials)
+
+SOLUTION: euler085
Aaron Schaefer
Eric Mertens
+Guillaume Nargeot
project-euler.055 project-euler.056 project-euler.057 project-euler.058
project-euler.059 project-euler.063 project-euler.067 project-euler.069
project-euler.071 project-euler.073 project-euler.075 project-euler.076
- project-euler.079 project-euler.092 project-euler.097 project-euler.099
- project-euler.100 project-euler.116 project-euler.117 project-euler.134
- project-euler.148 project-euler.150 project-euler.151 project-euler.164
- project-euler.169 project-euler.173 project-euler.175 project-euler.186
- project-euler.190 project-euler.203 project-euler.215 ;
+ project-euler.079 project-euler.085 project-euler.092 project-euler.097
+ project-euler.099 project-euler.100 project-euler.116 project-euler.117
+ project-euler.134 project-euler.148 project-euler.150 project-euler.151
+ project-euler.164 project-euler.169 project-euler.173 project-euler.175
+ project-euler.186 project-euler.190 project-euler.203 project-euler.215 ;
IN: project-euler
<PRIVATE
[ [ % ] each ] product-each
] "" make
] unit-test
+
+[ { } ] [ { { } { 1 } } [ ] product-map ] unit-test
+[ ] [ { { } { 1 } } [ drop ] product-each ] unit-test
: product-iter ( ns lengths -- )
[ 0 over [ 1 + ] change-nth ] dip carry-ns ;
-: start-product-iter ( sequence-product -- ns lengths )
+: start-product-iter ( sequences -- ns lengths )
[ [ drop 0 ] map ] [ [ length ] map ] bi ;
: end-product-iter? ( ns lengths -- ? )
:: product-each ( sequences quot -- )
sequences start-product-iter :> lengths :> ns
- [ ns lengths end-product-iter? ]
- [ ns sequences nths quot call ns lengths product-iter ] until ; inline
+ lengths [ 0 = ] any? [
+ [ ns lengths end-product-iter? ]
+ [ ns sequences nths quot call ns lengths product-iter ] until
+ ] unless ; inline
:: product-map ( sequences quot -- sequence )
0 :> i!
"adapted from lisp.vim
if exists("g:factor_norainbow")
- syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
+ syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL
else
- syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
- syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
- syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
- syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
- syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
- syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
- syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
- syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
- syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
- syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
+ syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1
+ syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2
+ syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3
+ syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4
+ syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5
+ syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6
+ syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7
+ syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8
+ syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9
+ syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0
endif
if exists("g:factor_norainbow")
add $12,%esp /* pop args from the stack */
ret /* return _with new stack_ */
-/* cpu.x86.32 calls this */
-DEF(bool,check_sse2,(void)):
- push %ebx
- mov $1,%eax
- cpuid
- shr $26,%edx
- and $1,%edx
- pop %ebx
- mov %edx,%eax
- ret
-
DEF(long long,read_timestamp_counter,(void)):
rdtsc
ret
#ifdef WINDOWS
.section .drectve
- .ascii " -export:check_sse2"
.ascii " -export:read_timestamp_counter"
#endif
add $STACK_PADDING,STACK_REG
jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
+/* cpu.x86.features calls this */
+DEF(bool,sse_version,(void)):
+ mov $0x1,RETURN_REG
+ cpuid
+ test $0x100000,%ecx
+ jnz sse_42
+ test $0x80000,%ecx
+ jnz sse_41
+ test $0x200,%ecx
+ jnz ssse_3
+ test $0x1,%ecx
+ jnz sse_3
+ test $0x4000000,%edx
+ jnz sse_2
+ test $0x2000000,%edx
+ jnz sse_1
+ mov $0,%eax
+ ret
+sse_42:
+ mov $42,RETURN_REG
+ ret
+sse_41:
+ mov $41,RETURN_REG
+ ret
+ssse_3:
+ mov $33,RETURN_REG
+ ret
+sse_3:
+ mov $30,RETURN_REG
+ ret
+sse_2:
+ mov $20,RETURN_REG
+ ret
+sse_1:
+ mov $10,RETURN_REG
+ ret
#ifdef WINDOWS
.section .drectve
+ .ascii " -export:sse_version"
.ascii " -export:c_to_factor"
#endif
projects / factor.git / commitdiff