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-array } " 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, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary 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 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." }
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary 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-array
{ $values { "c-type" "a C type" } }
-{ $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." } ;
+{ $description "Generates 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 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 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." } ;
+{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, an error will be thrown. The vocabulary can be loaded with the " { $link require-c-array } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary 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."
{ getter callable }
{ setter callable }
size
-align
-array-class
-array-constructor
-(array)-constructor
-direct-array-constructor ;
+align ;
TUPLE: c-type < abstract-c-type
boxer
] ?if
] if ;
-: ?require-word ( word/pair -- )
- dup word? [ drop ] [ first require ] ?if ;
-
! These words being foldable means that words need to be
! recompiled if a C type is redefined. Even so, folding the
! size facilitates some optimizations.
GENERIC: require-c-array ( c-type -- )
-M: object require-c-array
- drop ;
-
-M: c-type require-c-array
- array-class>> ?require-word ;
-
-M: string require-c-array
- c-type require-c-array ;
-
-M: array require-c-array
- first c-type require-c-array ;
-
-ERROR: specialized-array-vocab-not-loaded vocab word ;
+M: array require-c-array first require-c-array ;
-: c-array-constructor ( c-type -- word )
- array-constructor>> dup array?
- [ first2 specialized-array-vocab-not-loaded ] when ; foldable
+GENERIC: c-array-constructor ( c-type -- word )
-: c-(array)-constructor ( c-type -- word )
- (array)-constructor>> dup array?
- [ first2 specialized-array-vocab-not-loaded ] when ; foldable
+GENERIC: c-(array)-constructor ( c-type -- word )
-: c-direct-array-constructor ( c-type -- word )
- direct-array-constructor>> dup array?
- [ first2 specialized-array-vocab-not-loaded ] when ; foldable
+GENERIC: c-direct-array-constructor ( c-type -- word )
GENERIC: <c-array> ( len c-type -- array )
-M: object <c-array>
- c-array-constructor execute( len -- array ) ; inline
+
M: string <c-array>
- c-type <c-array> ; inline
-M: array <c-array>
- first c-type <c-array> ; inline
+ c-array-constructor execute( len -- array ) ; inline
GENERIC: (c-array) ( len c-type -- array )
-M: object (c-array)
- c-(array)-constructor execute( len -- array ) ; inline
+
M: string (c-array)
- c-type (c-array) ; inline
-M: array (c-array)
- first c-type (c-array) ; inline
+ c-(array)-constructor execute( len -- array ) ; inline
GENERIC: <c-direct-array> ( alien len c-type -- array )
-M: object <c-direct-array>
- c-direct-array-constructor execute( alien len -- array ) ; inline
+
M: string <c-direct-array>
- c-type <c-direct-array> ; inline
-M: array <c-direct-array>
- first c-type <c-direct-array> ; inline
+ c-direct-array-constructor execute( alien len -- array ) ; inline
: malloc-array ( n type -- alien )
[ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
: if-void ( type true false -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline
-: ?lookup ( vocab word -- word/pair )
- over vocab [ swap lookup ] [ 2array ] if ;
-
-: set-array-class* ( c-type vocab-stem type-stem -- c-type )
- {
- [
- [ "specialized-arrays." prepend ]
- [ "-array" append ] bi* ?lookup >>array-class
- ]
- [
- [ "specialized-arrays." prepend ]
- [ "<" "-array>" surround ] bi* ?lookup >>array-constructor
- ]
- [
- [ "specialized-arrays." prepend ]
- [ "(" "-array)" surround ] bi* ?lookup >>(array)-constructor
- ]
- [
- [ "specialized-arrays." prepend ]
- [ "<direct-" "-array>" surround ] bi* ?lookup >>direct-array-constructor
- ]
- } 2cleave ;
-
-: set-array-class ( c-type stem -- c-type )
- dup set-array-class* ;
-
CONSTANT: primitive-types
{
"char" "uchar"
[ >c-ptr ] >>unboxer-quot
"box_alien" >>boxer
"alien_offset" >>unboxer
- "alien" "void*" set-array-class*
"void*" define-primitive-type
<long-long-type>
8 >>align
"box_signed_8" >>boxer
"to_signed_8" >>unboxer
- "longlong" set-array-class
"longlong" define-primitive-type
<long-long-type>
8 >>align
"box_unsigned_8" >>boxer
"to_unsigned_8" >>unboxer
- "ulonglong" set-array-class
"ulonglong" define-primitive-type
<c-type>
bootstrap-cell >>align
"box_signed_cell" >>boxer
"to_fixnum" >>unboxer
- "long" set-array-class
"long" define-primitive-type
<c-type>
bootstrap-cell >>align
"box_unsigned_cell" >>boxer
"to_cell" >>unboxer
- "ulong" set-array-class
"ulong" define-primitive-type
<c-type>
4 >>align
"box_signed_4" >>boxer
"to_fixnum" >>unboxer
- "int" set-array-class
"int" define-primitive-type
<c-type>
4 >>align
"box_unsigned_4" >>boxer
"to_cell" >>unboxer
- "uint" set-array-class
"uint" define-primitive-type
<c-type>
2 >>align
"box_signed_2" >>boxer
"to_fixnum" >>unboxer
- "short" set-array-class
"short" define-primitive-type
<c-type>
2 >>align
"box_unsigned_2" >>boxer
"to_cell" >>unboxer
- "ushort" set-array-class
"ushort" define-primitive-type
<c-type>
1 >>align
"box_signed_1" >>boxer
"to_fixnum" >>unboxer
- "char" set-array-class
"char" define-primitive-type
<c-type>
1 >>align
"box_unsigned_1" >>boxer
"to_cell" >>unboxer
- "uchar" set-array-class
"uchar" define-primitive-type
<c-type>
1 >>align
"box_boolean" >>boxer
"to_boolean" >>unboxer
- "bool" set-array-class
"bool" define-primitive-type
<c-type>
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
<c-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
"long" "ptrdiff_t" typedef
<T> 1quotation >>unboxer-quot
*T 1quotation >>boxer-quot
number >>boxed-class
-T set-array-class
drop
;FUNCTOR
}
"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
$nl
-"Arrays of C structures can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
+"Arrays of C structures can be created with the " { $vocab-link "specialized-arrays" } " vocabulary." ;
ARTICLE: "c-unions" "C unions"
"A " { $snippet "union" } " in C defines a type large enough to hold its largest member. This is usually used to allocate a block of memory which can hold one of several types of values."
{ $subsection POSTPONE: C-UNION: }
"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
$nl
-"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
+"Arrays of C unions can be created with the " { $vocab-link "specialized-arrays" } " vocabulary." ;
[ name>> = ] with find nip offset>> ;
USE: vocabs.loader
-"struct-arrays" require
+"specialized-arrays" require
--- /dev/null
+unportable
sequences byte-arrays locals sequences.private macros fry
io.encodings.binary math.bitwise checksums accessors
checksums.common checksums.stream combinators combinators.smart
-specialized-arrays.uint literals hints ;
+specialized-arrays literals hints ;
+SPECIALIZED-ARRAY: uint
IN: checksums.md5
SINGLETON: md5
: pprint-struct-slot ( slot -- )
<flow \ { pprint-word
- {
+ f <inset {
[ name>> text ]
[ c-type>> dup string? [ text ] [ pprint* ] if ]
[ read-only>> [ \ read-only pprint-word ] when ]
[ initial>> [ \ initial: pprint-word pprint* ] when* ]
- } cleave
+ } cleave block>
\ } pprint-word block> ;
: pprint-struct ( struct -- )
! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.libraries
-alien.structs.fields alien.syntax ascii assocs byte-arrays
-classes.struct classes.tuple.private combinators
-compiler.tree.debugger compiler.units destructors
+USING: accessors alien alien.c-types alien.structs.fields ascii
+assocs byte-arrays classes.struct classes.tuple.private
+combinators compiler.tree.debugger compiler.units destructors
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.int specialized-arrays.ushort
-struct-arrays system tools.test ;
+prettyprint.config see sequences specialized-arrays system
+tools.test parser lexer eval ;
+SPECIALIZED-ARRAY: char
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: ushort
IN: classes.struct.tests
-<<
-: libfactor-ffi-tests-path ( -- string )
- "resource:" (normalize-path)
- {
- { [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
- { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
- { [ os unix? ] [ "libfactor-ffi-test.so" ] }
- } cond append-path ;
-
-"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
-
-"f-stdcall" libfactor-ffi-tests-path "stdcall" add-library
->>
-
SYMBOL: struct-test-empty
[ [ struct-test-empty { } define-struct-class ] with-compilation-unit ]
] with-destructors
] unit-test
-STRUCT: struct-test-ffi-foo
- { x int }
- { y int } ;
-
-LIBRARY: f-cdecl
-FUNCTION: int ffi_test_11 ( int a, struct-test-ffi-foo b, int c ) ;
-
-[ 14 ] [ 1 2 3 struct-test-ffi-foo <struct-boa> 4 ffi_test_11 ] unit-test
-
STRUCT: struct-test-array-slots
{ x int }
{ y ushort[6] initial: ushort-array{ 2 3 5 7 11 13 } }
STRUCT: struct-test-optimization
{ x { "int" 3 } } { y int } ;
+SPECIALIZED-ARRAY: struct-test-optimization
+
[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
[ t ] [
- [ 3 struct-test-optimization <direct-struct-array> third y>> ]
+ [ 3 <direct-struct-test-optimization-array> third y>> ]
{ <tuple> <tuple-boa> memory>struct y>> } inlined?
] unit-test
[ -77 ] [ S{ struct-that's-a-word { x -77 } } clone x>> ] unit-test
+! Interactive parsing of struct slot definitions
+[
+ "USE: classes.struct IN: classes.struct.tests STRUCT: unexpected-eof-test" <string-reader>
+ "struct-class-test-1" parse-stream
+] [ error>> error>> unexpected-eof? ] must-fail-with
+
+! S{ with non-struct type
+[
+ "USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
+ eval( -- value )
+] must-fail
+
+! Subclassing a struct class should not be allowed
+[
+ "USE: classes.struct IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
+ eval( -- )
+] must-fail
+
+! Remove c-type when struct class is forgotten
+[ ] [
+ "USE: classes.struct IN: classes.struct.tests TUPLE: a-struct ;" eval( -- )
+] unit-test
+
+[ f ] [ "a-struct" c-types get key? ] unit-test
classes.tuple classes.tuple.parser classes.tuple.private
combinators combinators.short-circuit combinators.smart
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 ;
+kernel kernel.private lexer libc locals macros make math
+math.order parser quotations sequences slots slots.private
+specialized-arrays vectors words summary namespaces assocs
+compiler.tree.propagation.transforms ;
FROM: slots => reader-word writer-word ;
IN: classes.struct
-! struct class
+SPECIALIZED-ARRAY: uchar
ERROR: struct-must-have-slots ;
+M: struct-must-have-slots summary
+ drop "Struct definitions must have slots" ;
+
TUPLE: struct
{ (underlying) c-ptr read-only } ;
TUPLE: struct-slot-spec < slot-spec
c-type ;
-PREDICATE: struct-class < tuple-class \ struct subclass-of? ;
+PREDICATE: struct-class < tuple-class
+ superclass \ struct eq? ;
+
+M: struct-class valid-superclass? drop f ;
-: struct-slots ( struct-class -- slots )
- "struct-slots" word-prop ;
+GENERIC: struct-slots ( struct-class -- slots )
+
+M: struct-class struct-slots "struct-slots" word-prop ;
! struct allocation
[ c-type>> c-type-align ] [ max ] map-reduce ;
PRIVATE>
-M: struct-class c-type
- name>> c-type ;
+M: struct-class c-type name>> c-type ;
-M: struct-class c-type-align
- "struct-align" word-prop ;
+M: struct-class c-type-align c-type c-type-align ;
-M: struct-class c-type-getter
- drop [ swap <displaced-alien> ] ;
+M: struct-class c-type-getter c-type c-type-getter ;
-M: struct-class c-type-setter
- [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
- '[ @ swap @ _ memcpy ] ;
+M: struct-class c-type-setter c-type c-type-setter ;
-M: struct-class c-type-boxer-quot
- (boxer-quot) ;
+M: struct-class c-type-boxer-quot c-type c-type-boxer-quot ;
-M: struct-class c-type-unboxer-quot
- (unboxer-quot) ;
+M: struct-class c-type-unboxer-quot c-type c-type-boxer-quot ;
-M: struct-class heap-size
- "struct-size" word-prop ;
+M: struct-class heap-size c-type heap-size ;
-M: struct byte-length
- class "struct-size" word-prop ; foldable
+M: struct byte-length class "struct-size" word-prop ; foldable
! class definition
<PRIVATE
: make-struct-prototype ( class -- prototype )
- [ heap-size <byte-array> ]
+ [ "struct-size" word-prop <byte-array> ]
[ memory>struct ]
[ struct-slots ] tri
[
: (define-struct-class) ( class slots offsets-quot -- )
[
+ empty?
[ struct-must-have-slots ]
- [ drop redefine-struct-tuple-class ] if-empty
+ [ redefine-struct-tuple-class ] if
]
swap '[
make-slots dup
: define-union-struct-class ( class slots -- )
[ union-struct-offsets ] (define-struct-class) ;
+M: struct-class reset-class
+ [ call-next-method ] [ name>> c-types get delete-at ] bi ;
+
ERROR: invalid-struct-slot token ;
: struct-slot-class ( c-type -- class' )
scan {
{ ";" [ f ] }
{ "{" [ parse-struct-slot over push t ] }
+ { f [ unexpected-eof ] }
[ invalid-struct-slot ]
} case ;
--- /dev/null
+Tuple-like access to structured raw memory
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.alien ;
+generalizations specialized-arrays ;
IN: cocoa.messages
+SPECIALIZED-ARRAY: void*
+
: make-sender ( method function -- quot )
[ over first , f , , second , \ alien-invoke , ] [ ] make ;
} ;
ARTICLE: "colors.constants" "Standard color database"
-"The " { $vocab-link "colors.constants" } " vocabulary bundles the X11 " { $snippet "rgb.txt" } " database and provides words for looking up color values."
+"The " { $vocab-link "colors.constants" } " vocabulary bundles the X11 " { $snippet "rgb.txt" } " database and Factor's " { $snippet "factor-colors.txt" } " theme database to provide words for looking up color values by name."
{ $subsection named-color }
{ $subsection named-colors }
{ $subsection POSTPONE: COLOR: } ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs math math.parser memoize io.encodings.utf8
-io.files lexer parser colors sequences splitting
-combinators.smart ascii ;
+io.files lexer parser colors sequences splitting ascii ;
IN: colors.constants
<PRIVATE
: parse-color ( line -- name color )
- [
- [ [ string>number 255 /f ] tri@ 1.0 <rgba> ] dip
- [ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap
- ] input<sequence ;
+ first4
+ [ [ string>number 255 /f ] tri@ 1.0 <rgba> ] dip
+ [ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap ;
: parse-rgb.txt ( lines -- assoc )
[ "!" head? not ] filter
[ parse-color ] H{ } map>assoc ;
MEMO: rgb.txt ( -- assoc )
- "resource:basis/colors/constants/rgb.txt" utf8 file-lines parse-rgb.txt ;
+ "resource:basis/colors/constants/rgb.txt"
+ "resource:basis/colors/constants/factor-colors.txt"
+ [ utf8 file-lines parse-rgb.txt ] bi@ assoc-union ;
PRIVATE>
--- /dev/null
+! Factor UI theme colors
+227 226 219 FactorLightTan
+172 167 147 FactorDarkTan
+ 81 91 105 FactorLightSlateBlue
+ 55 62 72 FactorDarkSlateBlue
IN: combinators.short-circuit
HELP: 0&&
-{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- ? )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 0||
-{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the first true result, or " { $link f } } }
+{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- ? )" } } { "?" "the first true result, or " { $link f } } }
{ $description "If every quotation in the sequence outputs " { $link f } ", outputs " { $link f } ", otherwise outputs the result of the first quotation that did not yield " { $link f } "." } ;
HELP: 1&&
-{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- ? )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 1||
-{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- )" } } { "?" "the first true result, or " { $link f } } }
+{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj -- ? )" } } { "?" "the first true result, or " { $link f } } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ;
HELP: 2&&
-{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- ? )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 2||
-{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- )" } } { "?" "the first true result, or " { $link f } } }
+{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 -- ? )" } } { "?" "the first true result, or " { $link f } } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ;
HELP: 3&&
-{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the result of the last quotation, or " { $link f } } }
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- ? )" } } { "?" "the result of the last quotation, or " { $link f } } }
{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ;
HELP: 3||
-{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- )" } } { "?" "the first true result, or " { $link f } } }
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( obj1 obj2 obj3 -- ? )" } } { "?" "the first true result, or " { $link f } } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
HELP: n&&
USING: kernel combinators quotations arrays sequences assocs
-locals generalizations macros fry ;
+generalizations macros fry ;
IN: combinators.short-circuit
-MACRO:: n&& ( quots n -- quot )
- [ f ] quots [| q |
- n
- [ q '[ drop _ ndup @ dup not ] ]
- [ '[ drop _ ndrop f ] ]
- bi 2array
- ] map
- n '[ _ nnip ] suffix 1array
+MACRO: n&& ( quots n -- quot )
+ [
+ [ [ f ] ] 2dip swap [
+ [ '[ drop _ ndup @ dup not ] ]
+ [ drop '[ drop _ ndrop f ] ]
+ 2bi 2array
+ ] with map
+ ] [ '[ _ nnip ] suffix 1array ] bi
[ cond ] 3append ;
<PRIVATE
: 2&& ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-&& ;
: 3&& ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-&& ;
-MACRO:: n|| ( quots n -- quot )
- [ f ] quots [| q |
- n
- [ q '[ drop _ ndup @ dup ] ]
- [ '[ _ nnip ] ]
- bi 2array
- ] map
- n '[ drop _ ndrop t ] [ f ] 2array suffix 1array
+MACRO: n|| ( quots n -- quot )
+ [
+ [ [ f ] ] 2dip swap [
+ [ '[ drop _ ndup @ dup ] ]
+ [ drop '[ _ nnip ] ]
+ 2bi 2array
+ ] with map
+ ] [ '[ drop _ ndrop t ] [ f ] 2array suffix 1array ] bi
[ cond ] 3append ;
<PRIVATE
! 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
{
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.cfg.instructions compiler.cfg.rpo
-compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities
-compiler.cfg.mr combinators.short-circuit accessors math
-sequences sets assocs ;
+USING: kernel combinators.short-circuit accessors math sequences
+sets assocs compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.def-use compiler.cfg.linearization
+compiler.cfg.utilities compiler.cfg.mr compiler.utilities ;
IN: compiler.cfg.checker
+! Check invariants
+
ERROR: bad-kill-block bb ;
: check-kill-block ( bb -- )
- dup instructions>> first2
- swap ##epilogue? [
- { [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1||
- ] [ ##branch? ] if
+ dup instructions>> dup penultimate ##epilogue? [
+ {
+ [ length 2 = ]
+ [ last { [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1|| ]
+ } 1&&
+ ] [ last ##branch? ] if
[ drop ] [ bad-kill-block ] if ;
ERROR: last-insn-not-a-jump bb ;
dup instructions>> last {
[ ##branch? ]
[ ##dispatch? ]
- [ ##conditional-branch? ]
+ [ ##compare-branch? ]
[ ##compare-imm-branch? ]
+ [ ##compare-float-ordered-branch? ]
+ [ ##compare-float-unordered-branch? ]
[ ##fixnum-add? ]
[ ##fixnum-sub? ]
[ ##fixnum-mul? ]
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-ordered-branch
+use: src1/double-rep src2/double-rep
+literal: cc ;
+
+INSN: ##compare-float-unordered-branch
+use: src1/double-rep src2/double-rep
+literal: cc ;
+
+PURE-INSN: ##compare-float-ordered
+def: dst/int-rep
+use: src1/double-rep src2/double-rep
+literal: cc
+temp: temp/int-rep ;
+
+PURE-INSN: ##compare-float-unordered
+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
+temp: temp1/int-rep temp2/int-rep
+literal: data-values tagged-values uninitialized-locs ;
-INSN: ##gc temp1 temp2 data-values tagged-values uninitialized-locs ;
+INSN: ##save-context
+temp: temp1/int-rep temp2/int-rep
+literal: callback-allowed? ;
! Instructions used by machine IR only.
-INSN: _prologue stack-frame ;
-INSN: _epilogue stack-frame ;
+INSN: _prologue
+literal: stack-frame ;
-INSN: _label id ;
+INSN: _epilogue
+literal: stack-frame ;
+
+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 ;
+
+INSN: _compare-branch
+literal: label
+use: src1/int-rep src2/int-rep
+literal: cc ;
-TUPLE: _conditional-branch < insn label src1 src2 cc ;
+INSN: _compare-imm-branch
+literal: label
+use: src1/int-rep
+constant: src2
+literal: cc ;
-INSN: _compare-branch < _conditional-branch ;
-INSN: _compare-imm-branch label src1 { src2 integer } cc ;
+INSN: _compare-float-unordered-branch
+literal: label
+use: src1/int-rep src2/int-rep
+literal: cc ;
-INSN: _compare-float-branch < _conditional-branch ;
+INSN: _compare-float-ordered-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
-! 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 -- slots )
+ "insn-slots" word-prop
+ [ type>> use eq? ] filter ;
+
+: insn-temp-slots ( class -- slots )
+ "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
[ 2inputs ] dip call ds-push ; inline
: emit-float-comparison ( cc -- )
- [ 2inputs ] dip ^^compare-float ds-push ; inline
+ [ 2inputs ] dip ^^compare-float-unordered ds-push ; inline
: emit-float>fixnum ( -- )
ds-pop ^^float>integer ^^tag-fixnum ds-push ;
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.libm:fsqrt [ drop "sqrt" emit-unary-float-function ] }
{ math.floats.private:float-min [ drop "fmin" emit-binary-float-function ] }
{ math.floats.private:float-max [ drop "fmax" emit-binary-float-function ] }
+ { math.private:float-mod [ drop "fmod" emit-binary-float-function ] }
} enable-intrinsics ;
: enable-min/max ( -- )
{ 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
[
M: ##compare-imm-branch linearize-insn
binary-conditional _compare-imm-branch emit-branch ;
-M: ##compare-float-branch linearize-insn
- binary-conditional _compare-float-branch emit-branch ;
+M: ##compare-float-ordered-branch linearize-insn
+ binary-conditional _compare-float-ordered-branch emit-branch ;
+
+M: ##compare-float-unordered-branch linearize-insn
+ binary-conditional _compare-float-unordered-branch emit-branch ;
: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
[ dup successors block-number ]
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces accessors compiler.cfg
compiler.cfg.linearization compiler.cfg.gc-checks
-compiler.cfg.linear-scan compiler.cfg.build-stack-frame ;
+compiler.cfg.save-contexts compiler.cfg.linear-scan
+compiler.cfg.build-stack-frame ;
IN: compiler.cfg.mr
: build-mr ( cfg -- mr )
insert-gc-checks
+ insert-save-contexts
linear-scan
flatten-cfg
build-stack-frame ;
\ No newline at end of file
! 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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: accessors compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.save-contexts kernel namespaces tools.test ;
+IN: compiler.cfg.save-contexts.tests
+
+0 vreg-counter set-global
+H{ } clone representations set
+
+V{
+ T{ ##unary-float-function f 2 3 "sqrt" }
+ T{ ##branch }
+} 0 test-bb
+
+0 get insert-save-context
+
+[
+ V{
+ T{ ##save-context f 1 2 f }
+ T{ ##unary-float-function f 2 3 "sqrt" }
+ T{ ##branch }
+ }
+] [
+ 0 get instructions>>
+] unit-test
+
+V{
+ T{ ##add f 1 2 3 }
+ T{ ##branch }
+} 0 test-bb
+
+0 get insert-save-context
+
+[
+ V{
+ T{ ##add f 1 2 3 }
+ T{ ##branch }
+ }
+] [
+ 0 get instructions>>
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.rpo cpu.architecture kernel sequences vectors ;
+IN: compiler.cfg.save-contexts
+
+! Insert context saves.
+
+: needs-save-context? ( insns -- ? )
+ [
+ {
+ [ ##unary-float-function? ]
+ [ ##binary-float-function? ]
+ [ ##alien-invoke? ]
+ [ ##alien-indirect? ]
+ } 1||
+ ] any? ;
+
+: needs-callback-context? ( insns -- ? )
+ [
+ {
+ [ ##alien-invoke? ]
+ [ ##alien-indirect? ]
+ } 1||
+ ] any? ;
+
+: insert-save-context ( bb -- )
+ dup instructions>> dup needs-save-context? [
+ int-rep next-vreg-rep
+ int-rep next-vreg-rep
+ pick needs-callback-context?
+ \ ##save-context new-insn prefix
+ >>instructions drop
+ ] [ 2drop ] if ;
+
+: insert-save-contexts ( cfg -- cfg' )
+ dup [ insert-save-context ] each-basic-block ;
[
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 -- )
: delete-conditional? ( bb -- ? )
{
- [ instructions>> last class { ##compare-branch ##compare-imm-branch ##compare-float-branch } memq? ]
+ [
+ instructions>> last class {
+ ##compare-branch
+ ##compare-imm-branch
+ ##compare-float-ordered-branch
+ ##compare-float-unordered-branch
+ } memq?
+ ]
[ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
} 1&& ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators combinators.short-circuit
cpu.architecture kernel layouts locals make math namespaces sequences
-sets vectors fry compiler.cfg compiler.cfg.instructions
-compiler.cfg.rpo arrays ;
+sets vectors fry arrays compiler.cfg compiler.cfg.instructions
+compiler.cfg.rpo compiler.utilities ;
IN: compiler.cfg.utilities
PREDICATE: kill-block < basic-block
instructions>> {
- [ length 2 = ]
- [ first kill-vreg-insn? ]
+ [ length 2 >= ]
+ [ penultimate kill-vreg-insn? ]
} 1&& ;
: back-edge? ( from to -- ? )
! 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-unordered-expr? ]
+ [ compare-float-ordered-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-unordered-expr? ] [ >compare-expr< \ ##compare-float-unordered-branch new-insn ] }
+ { [ dup compare-float-ordered-expr? ] [ >compare-expr< \ ##compare-float-ordered-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-unordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-unordered new-insn ] }
+ { [ dup compare-float-ordered-expr? ] [ >compare-expr< next-vreg \ ##compare-float-ordered 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 {
dup {
[ ##compare? ]
[ ##compare-imm? ]
- [ ##compare-float? ]
+ [ ##compare-float-unordered? ]
+ [ ##compare-float-ordered? ]
} 1|| [ f >>temp ] when
] map ;
T{ ##peek f 9 D -1 }
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-unordered f 12 10 11 cc< }
+ T{ ##compare-float-unordered f 14 10 11 cc/< }
T{ ##replace f 14 D 0 }
}
] [
T{ ##peek f 9 D -1 }
T{ ##unbox-float f 10 8 }
T{ ##unbox-float f 11 9 }
- T{ ##compare-float f 12 10 11 cc< }
+ T{ ##compare-float-unordered f 12 10 11 cc< }
T{ ##compare-imm f 14 12 5 cc= }
T{ ##replace f 14 D 0 }
} value-numbering-step trim-temps
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-ordered %compare-float-ordered
+CODEGEN: ##compare-float-unordered %compare-float-unordered
+CODEGEN: ##save-context %save-context
+
+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-ordered-branch %compare-float-ordered-branch
+CODEGEN: _compare-float-unordered-branch %compare-float-unordered-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 ;
[ [ uninitialized-locs>> ] [ temp1>> ] bi wipe-locs ]
[ data-values>> save-data-regs ]
[ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ]
+ [ [ temp1>> ] [ temp2>> ] bi t %save-context ]
[ tagged-values>> length %call-gc ]
[ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ]
[ data-values>> load-data-regs ]
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 -- ? )
M: ##alien-invoke generate-insn
params>>
- ! Save registers for GC
- %prepare-alien-invoke
! Unbox parameters
dup objects>registers
%prepare-var-args
! ##alien-indirect
M: ##alien-indirect generate-insn
params>>
- ! Save registers for GC
- %prepare-alien-invoke
! Save alien at top of stack to temporary storage
%prepare-alien-indirect
! Unbox parameters
[ 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 ;
compiler continuations effects io io.backend io.pathnames
io.streams.string kernel math memory namespaces
namespaces.private parser quotations sequences
-specialized-arrays.float stack-checker stack-checker.errors
-system threads tools.test words specialized-arrays.char ;
+specialized-arrays stack-checker stack-checker.errors
+system threads tools.test words ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: char
IN: compiler.tests.alien
<<
[ 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
pad-with-bottom >>phi-in-d drop ;
: live-value-indices ( values -- indices )
- [ length ] keep live-values get
+ [ length iota ] keep live-values get
'[ _ nth _ key? ] filter ; inline
: drop-indexed-values ( values indices -- node )
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.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
-specialized-arrays.double system sorting math.libm
-math.intervals quotations effects ;
+specialized-arrays system sorting math.libm
+math.intervals quotations effects alien ;
+SPECIALIZED-ARRAY: double
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
+
+! Converting /i to shift
+[ t ] [ [ >fixnum dup 0 >= [ 16 /i ] when ] { /i fixnum/i fixnum/i-fast } inlined? ] unit-test
+[ f ] [ [ >fixnum dup 0 >= [ 16 /i ] when ] { fixnum-shift-fast } inlined? ] unit-test
+[ f ] [ [ >float dup 0 >= [ 16 /i ] when ] { /i float/f } inlined? ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays combinators fry
+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
+
+! If SIMD is not available, inline alien-vector and set-alien-vector
+! to get a speedup
+: inline-unless-intrinsic ( word -- )
+ dup '[ drop _ dup "intrinsic" word-prop [ drop f ] [ def>> ] if ]
+ "custom-inlining" set-word-prop ;
+
+\ alien-vector inline-unless-intrinsic
+
+\ set-alien-vector inline-unless-intrinsic
] [ f ] if
] "custom-inlining" set-word-prop
+{ /i fixnum/i fixnum/i-fast bignum/i } [
+ [
+ in-d>> first2 [ value-info ] bi@ {
+ [ drop class>> integer class<= ]
+ [ drop interval>> 0 [a,a] interval>= ]
+ [ nip literal>> integer? ]
+ [ nip literal>> power-of-2? ]
+ } 2&& [ [ log2 neg shift ] ] [ f ] if
+ ] "custom-inlining" set-word-prop
+] each
+
! Integrate this with generic arithmetic optimization instead?
: both-inputs? ( #call class -- ? )
[ in-d>> first2 ] dip '[ value-info class>> _ class<= ] both? ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax core-foundation kernel assocs
-specialized-arrays.alien math sequences accessors ;
+specialized-arrays math sequences accessors ;
IN: core-foundation.dictionaries
+SPECIALIZED-ARRAY: void*
+
TYPEDEF: void* CFDictionaryRef
TYPEDEF: void* CFMutableDictionaryRef
TYPEDEF: void* CFDictionaryKeyCallBacks*
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.alien classes.struct
-specialized-arrays.int specialized-arrays.longlong
-core-foundation core-foundation.run-loop core-foundation.strings
+arrays specialized-arrays classes.struct core-foundation
+core-foundation.run-loop core-foundation.strings
core-foundation.time ;
IN: core-foundation.fsevents
+SPECIALIZED-ARRAY: void*
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: longlong
+
CONSTANT: kFSEventStreamCreateFlagUseCFTypes 2
CONSTANT: kFSEventStreamCreateFlagWatchRoot 4
! 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 ) foldable
+
+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 cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-imm cpu ( dst temp cc src1 src2 -- )
-HOOK: %compare-float cpu ( dst temp cc src1 src2 -- )
+HOOK: %compare-float-ordered cpu ( dst temp cc src1 src2 -- )
+HOOK: %compare-float-unordered cpu ( dst temp cc src1 src2 -- )
HOOK: %compare-branch cpu ( label cc src1 src2 -- )
HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- )
-HOOK: %compare-float-branch cpu ( label cc src1 src2 -- )
+HOOK: %compare-float-ordered-branch cpu ( label cc src1 src2 -- )
+HOOK: %compare-float-unordered-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 ( -- )
HOOK: %load-param-reg cpu ( stack reg rep -- )
-HOOK: %prepare-alien-invoke cpu ( -- )
+HOOK: %save-context cpu ( temp1 temp2 callback-allowed? -- )
HOOK: %prepare-var-args cpu ( -- )
r r n HEX: ffff bitand ORI ;
: immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ;
: LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;
+
+! Altivec/VMX instructions
+VA: VMHADDSHS 32 4
+VA: VMHRADDSHS 33 4
+VA: VMLADDUHM 34 4
+VA: VMSUMUBM 36 4
+VA: VMSUMMBM 37 4
+VA: VMSUMUHM 38 4
+VA: VMSUMUHS 39 4
+VA: VMSUMSHM 40 4
+VA: VMSUMSHS 41 4
+VA: VSEL 42 4
+VA: VPERM 43 4
+VA: VSLDOI 44 4
+VA: VMADDFP 46 4
+VA: VNMSUBFP 47 4
+
+VX: VADDUBM 0 4
+VX: VADDUHM 64 4
+VX: VADDUWM 128 4
+VX: VADDCUW 384 4
+VX: VADDUBS 512 4
+VX: VADDUHS 576 4
+VX: VADDUWS 640 4
+VX: VADDSBS 768 4
+VX: VADDSHS 832 4
+VX: VADDSWS 896 4
+
+VX: VSUBUBM 1024 4
+VX: VSUBUHM 1088 4
+VX: VSUBUWM 1152 4
+VX: VSUBCUW 1408 4
+VX: VSUBUBS 1536 4
+VX: VSUBUHS 1600 4
+VX: VSUBUWS 1664 4
+VX: VSUBSBS 1792 4
+VX: VSUBSHS 1856 4
+VX: VSUBSWS 1920 4
+
+VX: VMAXUB 2 4
+VX: VMAXUH 66 4
+VX: VMAXUW 130 4
+VX: VMAXSB 258 4
+VX: VMAXSH 322 4
+VX: VMAXSW 386 4
+
+VX: VMINUB 514 4
+VX: VMINUH 578 4
+VX: VMINUW 642 4
+VX: VMINSB 770 4
+VX: VMINSH 834 4
+VX: VMINSW 898 4
+
+VX: VAVGUB 1026 4
+VX: VAVGUH 1090 4
+VX: VAVGUW 1154 4
+VX: VAVGSB 1282 4
+VX: VAVGSH 1346 4
+VX: VAVGSW 1410 4
+
+VX: VRLB 4 4
+VX: VRLH 68 4
+VX: VRLW 132 4
+VX: VSLB 260 4
+VX: VSLH 324 4
+VX: VSLW 388 4
+VX: VSL 452 4
+VX: VSRB 516 4
+VX: VSRH 580 4
+VX: VSRW 644 4
+VX: VSR 708 4
+VX: VSRAB 772 4
+VX: VSRAH 836 4
+VX: VSRAW 900 4
+
+VX: VAND 1028 4
+VX: VANDC 1092 4
+VX: VOR 1156 4
+VX: VNOR 1284 4
+VX: VXOR 1220 4
+
+VXD: MFVSCR 1540 4
+VXB: MTVSCR 1604 4
+
+VX: VMULOUB 8 4
+VX: VMULOUH 72 4
+VX: VMULOSB 264 4
+VX: VMULOSH 328 4
+VX: VMULEUB 520 4
+VX: VMULEUH 584 4
+VX: VMULESB 776 4
+VX: VMULESH 840 4
+VX: VSUM4UBS 1544 4
+VX: VSUM4SBS 1800 4
+VX: VSUM4SHS 1608 4
+VX: VSUM2SWS 1672 4
+VX: VSUMSWS 1928 4
+
+VX: VADDFP 10 4
+VX: VSUBFP 74 4
+
+VXDB: VREFP 266 4
+VXDB: VRSQRTEFP 330 4
+VXDB: VEXPTEFP 394 4
+VXDB: VLOGEFP 458 4
+VXDB: VRFIN 522 4
+VXDB: VRFIZ 586 4
+VXDB: VRFIP 650 4
+VXDB: VRFIM 714 4
+
+VX: VCFUX 778 4
+VX: VCFSX 842 4
+VX: VCTUXS 906 4
+VX: VCTSXS 970 4
+
+VX: VMAXFP 1034 4
+VX: VMINFP 1098 4
+
+VX: VMRGHB 12 4
+VX: VMRGHH 76 4
+VX: VMRGHW 140 4
+VX: VMRGLB 268 4
+VX: VMRGLH 332 4
+VX: VMRGLW 396 4
+
+VX: VSPLTB 524 4
+VX: VSPLTH 588 4
+VX: VSPLTW 652 4
+
+VXA: VSPLTISB 780 4
+VXA: VSPLTISH 844 4
+VXA: VSPLTISW 908 4
+
+VX: VSLO 1036 4
+VX: VSRO 1100 4
+
+VX: VPKUHUM 14 4
+VX: VPKUWUM 78 4
+VX: VPKUHUS 142 4
+VX: VPKUWUS 206 4
+VX: VPKSHUS 270 4
+VX: VPKSWUS 334 4
+VX: VPKSHSS 398 4
+VX: VPKSWSS 462 4
+VX: VPKPX 782 4
+
+VXDB: VUPKHSB 526 4
+VXDB: VUPKHSH 590 4
+VXDB: VUPKLSB 654 4
+VXDB: VUPKLSH 718 4
+VXDB: VUPKHPX 846 4
+VXDB: VUPKLPX 974 4
+
+: -T ( strm a b -- strm-t a b ) [ 16 bitor ] 2dip ;
+
+XD: DST 0 342 31
+: DSTT ( strm a b -- ) -T DST ;
+
+XD: DSTST 0 374 31
+: DSTSTT ( strm a b -- ) -T DSTST ;
+
+XD: (DSS) 0 822 31
+: DSS ( strm -- ) 0 0 (DSS) ;
+: DSSALL ( -- ) 16 0 0 (DSS) ;
+
+XD: LVEBX 0 7 31
+XD: LVEHX 0 39 31
+XD: LVEWX 0 71 31
+XD: LVSL 0 6 31
+XD: LVSR 0 38 31
+XD: LVX 0 103 31
+XD: LVXL 0 359 31
+
+XD: STVEBX 0 135 31
+XD: STVEHX 0 167 31
+XD: STVEWX 0 199 31
+XD: STVX 0 231 31
+XD: STVXL 0 487 31
+
+VXR: VCMPBFP 0 966 4
+VXR: VCMPEQFP 0 198 4
+VXR: VCMPEQUB 0 6 4
+VXR: VCMPEQUH 0 70 4
+VXR: VCMPEQUW 0 134 4
+VXR: VCMPGEFP 0 454 4
+VXR: VCMPGTFP 0 710 4
+VXR: VCMPGTSB 0 774 4
+VXR: VCMPGTSH 0 838 4
+VXR: VCMPGTSW 0 902 4
+VXR: VCMPGTUB 0 518 4
+VXR: VCMPGTUH 0 582 4
+VXR: VCMPGTUW 0 646 4
+
+VXR: VCMPBFP. 1 966 4
+VXR: VCMPEQFP. 1 198 4
+VXR: VCMPEQUB. 1 6 4
+VXR: VCMPEQUH. 1 70 4
+VXR: VCMPEQUW. 1 134 4
+VXR: VCMPGEFP. 1 454 4
+VXR: VCMPGTFP. 1 710 4
+VXR: VCMPGTSB. 1 774 4
+VXR: VCMPGTSH. 1 838 4
+VXR: VCMPGTSW. 1 902 4
+VXR: VCMPGTUB. 1 518 4
+VXR: VCMPGTUH. 1 582 4
+VXR: VCMPGTUW. 1 646 4
+
: x-insn ( a s b rc xo opcode -- )
[ { 1 0 11 21 16 } bitfield ] dip insn ;
+: xd-insn ( d a b rc xo opcode -- )
+ [ { 1 0 11 16 21 } bitfield ] dip insn ;
+
: (X) ( -- word quot )
CREATE scan-word scan-word scan-word [ x-insn ] 3curry ;
-SYNTAX: X: (X) (( a s b -- )) define-declared ;
+: (XD) ( -- word quot )
+ CREATE scan-word scan-word scan-word [ xd-insn ] 3curry ;
+
+SYNTAX: X: (X) (( a s b -- )) define-declared ;
+SYNTAX: XD: (XD) (( d a b -- )) define-declared ;
: (1) ( quot -- quot' ) [ 0 ] prepose ;
CREATE scan-word scan-word scan-word scan-word
[ xo-insn ] 2curry 2curry ;
-SYNTAX: XO: (XO) (( a s b -- )) define-declared ;
+SYNTAX: XO: (XO) (( d a b -- )) define-declared ;
-SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ;
+SYNTAX: XO1: (XO) (1) (( d a -- )) define-declared ;
GENERIC# (B) 2 ( dest aa lk -- )
M: integer (B) 18 i-insn ;
SYNTAX: B:
CREATE-B scan-word scan-word scan-word scan-word scan-word
'[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ;
+
+: va-insn ( d a b c xo opcode -- )
+ [ { 0 6 11 16 21 } bitfield ] dip insn ;
+
+: (VA) ( -- word quot )
+ CREATE scan-word scan-word [ va-insn ] 2curry ;
+
+SYNTAX: VA: (VA) (( d a b c -- )) define-declared ;
+
+: vx-insn ( d a b xo opcode -- )
+ [ { 0 11 16 21 } bitfield ] dip insn ;
+
+: (VX) ( -- word quot )
+ CREATE scan-word scan-word [ vx-insn ] 2curry ;
+: (VXD) ( -- word quot )
+ CREATE scan-word scan-word '[ 0 0 _ _ vx-insn ] ;
+: (VXA) ( -- word quot )
+ CREATE scan-word scan-word '[ [ 0 ] dip 0 _ _ vx-insn ] ;
+: (VXB) ( -- word quot )
+ CREATE scan-word scan-word '[ [ 0 0 ] dip _ _ vx-insn ] ;
+: (VXDB) ( -- word quot )
+ CREATE scan-word scan-word '[ [ 0 ] dip _ _ vx-insn ] ;
+
+SYNTAX: VX: (VX) (( d a b -- )) define-declared ;
+SYNTAX: VXD: (VXD) (( d -- )) define-declared ;
+SYNTAX: VXA: (VXA) (( a -- )) define-declared ;
+SYNTAX: VXB: (VXB) (( b -- )) define-declared ;
+SYNTAX: VXDB: (VXDB) (( d b -- )) define-declared ;
+
+: vxr-insn ( d a b rc xo opcode -- )
+ [ { 0 10 11 16 21 } bitfield ] dip insn ;
+
+: (VXR) ( -- word quot )
+ CREATE scan-word scan-word scan-word [ vxr-insn ] 3curry ;
+
+SYNTAX: VXR: (VXR) (( d a b -- )) define-declared ;
+
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 ;
func f %alien-invoke
dst float-function-return ;
+! Internal format is always double-precision on PowerPC
+M: ppc %single>double-float FMR ;
+
+M: ppc %double>single-float FMR ;
+
+M: ppc %unbox-alien ( dst src -- )
+ alien-offset LWZ ;
+
M:: ppc %unbox-any-c-ptr ( dst src temp -- )
[
{ "is-byte-array" "end" "start" } [ define-label ] each
"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
register 1 gc-root gc-root@ LWZ ;
M:: ppc %call-gc ( gc-root-count -- )
- %prepare-alien-invoke
3 1 gc-root-base local@ ADDI
gc-root-count 4 LI
"inline_gc" f %alien-invoke ;
dst \ t %load-reference
"end" get resolve-label ; inline
-:: %boolean ( dst temp cc -- )
+:: %boolean ( dst cc temp -- )
cc negate-cc order-cc {
{ cc< [ dst temp \ BLT f (%boolean) ] }
{ cc<= [ dst temp \ BLE f (%boolean) ] }
: (%compare-float-unordered) ( src1 src2 -- ) [ 0 ] dip FCMPU ; inline
: (%compare-float-ordered) ( src1 src2 -- ) [ 0 ] dip FCMPO ; inline
-:: (%compare-float) ( cc src1 src2 -- branch1 branch2 )
+:: (%compare-float) ( src1 src2 cc compare -- 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 ] }
+ { cc< [ src1 src2 \ compare execute( a b -- ) \ BLT f ] }
+ { cc<= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BEQ ] }
+ { cc> [ src1 src2 \ compare execute( a b -- ) \ BGT f ] }
+ { cc>= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BEQ ] }
+ { cc= [ src1 src2 \ compare execute( a b -- ) \ BEQ f ] }
+ { cc<> [ src1 src2 \ compare execute( a b -- ) \ BLT \ BGT ] }
+ { cc<>= [ src1 src2 \ compare execute( a b -- ) \ BNO f ] }
+ { cc/< [ src1 src2 \ compare execute( a b -- ) \ BGE f ] }
+ { cc/<= [ src1 src2 \ compare execute( a b -- ) \ BGT \ BO ] }
+ { cc/> [ src1 src2 \ compare execute( a b -- ) \ BLE f ] }
+ { cc/>= [ src1 src2 \ compare execute( a b -- ) \ BLT \ BO ] }
+ { cc/= [ src1 src2 \ compare execute( a b -- ) \ BNE f ] }
+ { cc/<> [ src1 src2 \ compare execute( a b -- ) \ BEQ \ BO ] }
+ { cc/<>= [ src1 src2 \ compare execute( a b -- ) \ BO f ] }
} case ; inline
-M: ppc %compare (%compare) %boolean ;
-M: ppc %compare-imm (%compare-imm) %boolean ;
-M:: ppc %compare-float ( dst temp cc src1 src2 -- )
- cc negate-cc src1 src2 (%compare-float) :> branch2 :> branch1
+M: ppc %compare [ (%compare) ] 2dip %boolean ;
+
+M: ppc %compare-imm [ (%compare-imm) ] 2dip %boolean ;
+
+M:: ppc %compare-float-ordered ( dst src1 src2 cc temp -- )
+ src1 src2 cc negate-cc \ (%compare-float-ordered) (%compare-float) :> branch2 :> branch1
+ dst temp branch1 branch2 (%boolean) ;
+
+M:: ppc %compare-float-unordered ( dst src1 src2 cc temp -- )
+ src1 src2 cc negate-cc \ (%compare-float-unordered) (%compare-float) :> branch2 :> branch1
dst temp branch1 branch2 (%boolean) ;
:: %branch ( label cc -- )
{ cc/= [ label BNE ] }
} case ;
-M: ppc %compare-branch (%compare) %branch ;
-M: ppc %compare-imm-branch (%compare-imm) %branch ;
-M:: ppc %compare-float-branch ( label cc src1 src2 -- )
- cc src1 src2 (%compare-float) :> branch2 :> branch1
+M:: ppc %compare-branch ( label src1 src2 cc -- )
+ src1 src2 (%compare)
+ label cc %branch ;
+
+M:: ppc %compare-imm-branch ( label src1 src2 cc -- )
+ src1 src2 (%compare-imm)
+ label cc %branch ;
+
+:: (%branch) ( label branch1 branch2 -- )
label branch1 execute( label -- )
- branch2 [ label branch2 execute( label -- ) ] when ;
+ branch2 [ label branch2 execute( label -- ) ] when ; inline
+
+M:: ppc %compare-float-ordered-branch ( label src1 src2 cc -- )
+ src1 src2 cc \ (%compare-float-ordered) (%compare-float) :> branch2 :> branch1
+ label branch1 branch2 (%branch) ;
+
+M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
+ src1 src2 cc \ (%compare-float-unordered) (%compare-float) :> branch2 :> branch1
+ label branch1 branch2 (%branch) ;
: 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 ;
! Call the function
"box_value_struct" f %alien-invoke ;
-M: ppc %prepare-alien-invoke
+M:: ppc %save-context ( temp1 temp2 callback-allowed? -- )
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
- scratch-reg "stack_chain" f %alien-global
- scratch-reg scratch-reg 0 LWZ
- 1 scratch-reg 0 STW
- ds-reg scratch-reg 8 STW
- rs-reg scratch-reg 12 STW ;
+ temp1 "stack_chain" f %alien-global
+ temp1 temp1 0 LWZ
+ 1 temp1 0 STW
+ callback-allowed? [
+ ds-reg temp1 8 STW
+ rs-reg temp1 12 STW
+ ] when ;
M: ppc %alien-invoke ( symbol dll -- )
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
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
+"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
-USING: cpu.x86.features tools.test kernel sequences math system ;
+USING: cpu.x86.features tools.test kernel sequences math math.order system ;
IN: cpu.x86.features.tests
cpu x86? [
- [ t ] [ sse2? { t f } member? ] unit-test
+ [ t ] [ sse-version 0 42 between? ] unit-test
[ t ] [ [ 10000 [ ] times ] count-instructions integer? ] unit-test
] when
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel math alien.syntax ;
+USING: system kernel math math.order math.parser namespaces
+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 only 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-version" get [ string>number min ] when*
+[ sse-string write " detected" print ]
+[ install-sse-check ]
+[ enable-sse ] tri
--- /dev/null
+unportable
-! 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 [ [ MOVSS ] [ drop dup 0 SHUFPS ] 2bi ] }
+ { double-2-rep [ [ MOVSD ] [ drop dup UNPCKLPD ] 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 MOVLHPS
+ ]
+ }
+ } case ;
+
+M:: x86 %gather-vector-2 ( dst src1 src2 rep -- )
+ rep {
+ {
+ double-2-rep
+ [
+ dst src1 MOVSD
+ dst src2 UNPCKLPD
+ ]
+ }
+ } 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? ;
! Pass number of roots as second parameter
param-reg-2 gc-root-count MOV
! Call GC
- %prepare-alien-invoke
"inline_gc" f %alien-invoke ;
M: x86 %alien-global
temp 0 MOV \ t rc-absolute-cell rel-immediate
dst temp word execute ; inline
-M:: x86 %compare ( dst temp cc src1 src2 -- )
+M:: x86 %compare ( dst src1 src2 cc temp -- )
src1 src2 CMP
cc order-cc {
{ cc< [ dst temp \ CMOVL %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 ;
: %cmov-float= ( dst src -- )
"no-move" resolve-label
] with-scope ;
-M:: x86 %compare-float ( dst temp cc src1 src2 -- )
+:: (%compare-float) ( dst src1 src2 cc temp compare -- )
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 -- )
+ { cc< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVA %boolean ] }
+ { cc<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
+ { cc> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVA %boolean ] }
+ { cc>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVAE %boolean ] }
+ { cc= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float= %boolean ] }
+ { cc<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNE %boolean ] }
+ { cc<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVNP %boolean ] }
+ { cc/< [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
+ { cc/<= [ src2 src1 \ compare execute( a b -- ) dst temp \ CMOVB %boolean ] }
+ { cc/> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVBE %boolean ] }
+ { cc/>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVB %boolean ] }
+ { cc/= [ src1 src2 \ compare execute( a b -- ) dst temp \ %cmov-float/= %boolean ] }
+ { cc/<> [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVE %boolean ] }
+ { cc/<>= [ src1 src2 \ compare execute( a b -- ) dst temp \ CMOVP %boolean ] }
+ } case ; inline
+
+M: x86 %compare-float-ordered ( dst src1 src2 cc temp -- )
+ \ COMISD (%compare-float) ;
+
+M: x86 %compare-float-unordered ( dst src1 src2 cc temp -- )
+ \ UCOMISD (%compare-float) ;
+
+M:: x86 %compare-branch ( label src1 src2 cc -- )
src1 src2 CMP
cc order-cc {
{ cc< [ label JL ] }
: %jump-float/= ( label -- )
[ JNE ] [ JP ] bi ;
-M:: x86 %compare-float-branch ( label cc src1 src2 -- )
+:: (%compare-float-branch) ( label src1 src2 cc compare -- )
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 ] }
+ { cc< [ src2 src1 \ compare execute( a b -- ) label JA ] }
+ { cc<= [ src2 src1 \ compare execute( a b -- ) label JAE ] }
+ { cc> [ src1 src2 \ compare execute( a b -- ) label JA ] }
+ { cc>= [ src1 src2 \ compare execute( a b -- ) label JAE ] }
+ { cc= [ src1 src2 \ compare execute( a b -- ) label %jump-float= ] }
+ { cc<> [ src1 src2 \ compare execute( a b -- ) label JNE ] }
+ { cc<>= [ src1 src2 \ compare execute( a b -- ) label JNP ] }
+ { cc/< [ src2 src1 \ compare execute( a b -- ) label JBE ] }
+ { cc/<= [ src2 src1 \ compare execute( a b -- ) label JB ] }
+ { cc/> [ src1 src2 \ compare execute( a b -- ) label JBE ] }
+ { cc/>= [ src1 src2 \ compare execute( a b -- ) label JB ] }
+ { cc/= [ src1 src2 \ compare execute( a b -- ) label %jump-float/= ] }
+ { cc/<> [ src1 src2 \ compare execute( a b -- ) label JE ] }
+ { cc/<>= [ src1 src2 \ compare execute( a b -- ) 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 %compare-float-ordered-branch ( label src1 src2 cc -- )
+ \ COMISD (%compare-float-branch) ;
+
+M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- )
+ \ UCOMISD (%compare-float-branch) ;
+
+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 ;
-M: x86 %prepare-alien-invoke
+M:: x86 %save-context ( temp1 temp2 callback-allowed? -- )
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
- temp-reg "stack_chain" f %alien-global
- temp-reg temp-reg [] MOV
- temp-reg [] stack-reg MOV
- temp-reg [] cell SUB
- temp-reg 2 cells [+] ds-reg MOV
- temp-reg 3 cells [+] rs-reg MOV ;
+ temp1 "stack_chain" f %alien-global
+ temp1 temp1 [] MOV
+ temp2 stack-reg cell neg [+] LEA
+ temp1 [] temp2 MOV
+ callback-allowed? [
+ temp1 2 cells [+] ds-reg MOV
+ temp1 3 cells [+] rs-reg MOV
+ ] when ;
M: x86 value-struct? drop t ;
: 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
libc calendar.format byte-arrays destructors prettyprint
accessors strings serialize io.encodings.binary io.encodings.utf8
alien.strings io.streams.byte-array summary present urls
-specialized-arrays.uint specialized-arrays.alien db.private ;
+specialized-arrays db.private ;
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: void*
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
"User-defined errors can have customized printed representation by implementing a generic word:"
{ $subsection error. }
"A number of words facilitate interactive debugging of errors:"
+{ $subsection :error }
{ $subsection :s }
{ $subsection :r }
{ $subsection :c }
{ $subsection :2 }
{ $subsection :3 }
{ $subsection :res }
-"You can read more about error handling in " { $link "errors" } "." ;
+"You can read more about error handling in " { $link "errors" } "."
+$nl
+"Note that in Factor, the debugger is a tool for printing and inspecting errors, not for walking through code. For the latter, see " { $link "ui-walker" } "." ;
ABOUT: "debugger"
+HELP: :error
+{ $description "Prints the most recent error. Used for interactive debugging." } ;
+
HELP: :s
{ $description "Prints the data stack at the time of the most recent error. Used for interactive debugging." } ;
: primitive-error. ( error -- )
"Unimplemented primitive" print drop ;
+: fp-trap-error. ( error -- )
+ "Floating point trap" print drop ;
+
PREDICATE: vm-error < array
{
{ [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] }
- [ second 0 15 between? ]
+ [ second 0 16 between? ]
} cond ;
: vm-errors ( error -- n errors )
{ 13 [ retainstack-underflow. ] }
{ 14 [ retainstack-overflow. ] }
{ 15 [ memory-error. ] }
+ { 16 [ fp-trap-error. ] }
} ; inline
M: vm-error summary drop "VM error" ;
ICON: constant constant-word
ICON: word normal-word
ICON: word-link word-help-article
-ICON: link help-article
+ICON: topic help-article
ICON: runnable-vocab runnable-vocab
ICON: vocab open-vocab
ICON: vocab-link unopen-vocab
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
game-input.dinput.keys-array io.encodings.utf16
io.encodings.utf16n kernel locals math math.bitwise
math.rectangles namespaces parser sequences shuffle
-struct-arrays ui.backend.windows vectors windows.com
+specialized-arrays ui.backend.windows vectors windows.com
windows.dinput windows.dinput.constants windows.errors
windows.kernel32 windows.messages windows.ole32
windows.user32 classes.struct ;
+SPECIALIZED-ARRAY: DIDEVICEOBJECTDATA
IN: game-input.dinput
+
CONSTANT: MOUSE-BUFFER-SIZE 16
SINGLETON: dinput-game-input-backend
: find-mouse ( -- )
GUID_SysMouse device-for-guid
- [ configure-mouse ]
- [ +mouse-device+ set-global ] bi
- 0 0 0 0 8 f <array> mouse-state boa
- +mouse-state+ set-global
- MOUSE-BUFFER-SIZE DIDEVICEOBJECTDATA <struct-array>
- +mouse-buffer+ set-global ;
+ [ configure-mouse ] [ +mouse-device+ set-global ] bi
+ 0 0 0 0 8 f <array> mouse-state boa +mouse-state+ set-global
+ MOUSE-BUFFER-SIZE <DIDEVICEOBJECTDATA-array> +mouse-buffer+ set-global ;
: device-info ( device -- DIDEVICEIMAGEINFOW )
DIDEVICEINSTANCEW <struct>
: ($code) ( presentation quot -- )
[
- snippet-style get [
+ code-char-style get [
last-element off
[ ($code-style) ] dip with-nesting
] with-style
: ($see) ( word quot -- )
[
- snippet-style get [
+ code-char-style get [
code-style get swap with-nesting
] with-style
] ($block) ; inline
SYMBOL: link-style
H{
- { foreground COLOR: dark-blue }
+ { foreground COLOR: DodgerBlue4 }
{ font-style bold }
} link-style set-global
{ font-size 18 }
{ font-style bold }
{ wrap-margin 500 }
- { page-color COLOR: light-gray }
+ { foreground COLOR: FactorDarkSlateBlue }
+ { page-color COLOR: FactorLightTan }
{ border-width 5 }
} title-style set-global
H{
{ font-name "monospace" }
{ font-size 12 }
- { foreground COLOR: navy-blue }
+ { foreground COLOR: DarkOrange4 }
} snippet-style set-global
+SYMBOL: code-char-style
+H{
+ { font-name "monospace" }
+ { font-size 12 }
+} code-char-style set-global
+
SYMBOL: code-style
H{
- { page-color COLOR: gray80 }
+ { page-color COLOR: FactorLightTan }
{ border-width 5 }
{ wrap-margin f }
} code-style set-global
SYMBOL: url-style
H{
{ font-name "monospace" }
- { foreground COLOR: blue }
+ { foreground COLOR: DodgerBlue4 }
} url-style set-global
SYMBOL: warning-style
SYMBOL: table-style
H{
{ table-gap { 5 5 } }
- { table-border COLOR: light-gray }
+ { table-border COLOR: FactorLightTan }
} table-style set-global
SYMBOL: list-style
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays byte-vectors classes
-combinators definitions fry generic generic.single
+combinators definitions effects fry generic generic.single
generic.standard hashtables io.binary io.streams.string kernel
kernel.private math math.parser namespaces parser sbufs
sequences splitting splitting.private strings vectors words ;
M: object specializer-declaration class ;
+: specializer ( word -- specializer )
+ "specializer" word-prop ;
+
: make-specializer ( specs -- quot )
dup length <reversed>
[ (picker) 2array ] 2map
[ ] [ swap [ f ] \ if 3array append [ ] like ] map-reduce
] if-empty ;
-: specializer-cases ( quot word -- default alist )
+: specializer-cases ( quot specializer -- alist )
dup [ array? ] all? [ 1array ] unless [
- [ make-specializer ] keep
- [ specializer-declaration ] map '[ _ declare ] pick append
- ] { } map>assoc ;
+ [ nip make-specializer ]
+ [ [ specializer-declaration ] map swap '[ _ declare @ ] ] 2bi
+ ] with { } map>assoc ;
-: specialize-quot ( quot specializer -- quot' )
- specializer-cases alist>quot ;
+: specialize-quot ( quot word specializer -- quot' )
+ [ drop nip def>> ] [ nip specializer-cases ] 3bi alist>quot ;
! compiler.tree.propagation.inlining sets this to f
SYMBOL: specialize-method?
: specialize-method ( quot method -- quot' )
[ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
- [ "method-generic" word-prop "specializer" word-prop ] bi
- [ specialize-quot ] when* ;
+ [ dup "method-generic" word-prop specializer ] bi
+ [ specialize-quot ] [ drop ] if* ;
: standard-method? ( method -- ? )
dup method-body? [
[ def>> ] keep
dup generic? [ drop ] [
[ dup standard-method? [ specialize-method ] [ drop ] if ]
- [ "specializer" word-prop [ specialize-quot ] when* ]
+ [ dup specializer [ specialize-quot ] [ drop ] if* ]
bi
] if ;
images.bitmap.loading images.loader io io.binary
io.encodings.binary io.encodings.string io.files
io.streams.limited kernel locals macros math math.bitwise
-math.functions namespaces sequences specialized-arrays.uint
-specialized-arrays.ushort strings summary ;
+math.functions namespaces sequences specialized-arrays
+strings summary ;
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: ushort
IN: images.bitmap
: write2 ( n -- ) 2 >le write ;
compression.run-length fry grouping images images.loader io
io.binary io.encodings.8-bit io.encodings.binary
io.encodings.string io.streams.limited kernel math math.bitwise
-sequences specialized-arrays.ushort summary ;
+sequences specialized-arrays summary ;
QUALIFIED-WITH: bitstreams b
+SPECIALIZED-ARRAY: ushort
IN: images.bitmap.loading
SINGLETON: bitmap-image
io.binary io.encodings.ascii io.encodings.binary
io.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack prettyprint sequences
-strings math.vectors specialized-arrays.float locals
+strings math.vectors specialized-arrays locals
images.loader ;
+SPECIALIZED-ARRAY: float
IN: images.tiff
SINGLETON: tiff-image
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes.struct kernel destructors bit-arrays
-sequences assocs struct-arrays math namespaces locals fry unix
-unix.linux.epoll unix.time io.ports io.backend.unix
-io.backend.unix.multiplexers ;
+sequences assocs specialized-arrays math namespaces
+locals fry unix unix.linux.epoll unix.time io.ports
+io.backend.unix io.backend.unix.multiplexers ;
+SPECIALIZED-ARRAY: epoll-event
IN: io.backend.unix.multiplexers.epoll
TUPLE: epoll-mx < mx events ;
: <epoll-mx> ( -- mx )
epoll-mx new-mx
max-events epoll_create dup io-error >>fd
- max-events epoll-event <struct-array> >>events ;
+ max-events <epoll-event-array> >>events ;
M: epoll-mx dispose* fd>> close-file ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types combinators destructors
-io.backend.unix kernel math.bitwise sequences struct-arrays unix
-unix.kqueue unix.time assocs io.backend.unix.multiplexers
-classes.struct ;
+io.backend.unix kernel math.bitwise sequences
+specialized-arrays unix unix.kqueue unix.time assocs
+io.backend.unix.multiplexers classes.struct ;
+SPECIALIZED-ARRAY: kevent
IN: io.backend.unix.multiplexers.kqueue
TUPLE: kqueue-mx < mx events ;
: <kqueue-mx> ( -- mx )
kqueue-mx new-mx
kqueue dup io-error >>fd
- max-events \ kevent <struct-array> >>events ;
+ max-events <kevent-array> >>events ;
M: kqueue-mx dispose* fd>> close-file ;
io.backend io.files io.files.info io.files.unix kernel math system unix
unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
sequences grouping alien.strings io.encodings.utf8 unix.types
-arrays io.files.info.unix classes.struct struct-arrays ;
+arrays io.files.info.unix classes.struct
+specialized-arrays ;
+SPECIALIZED-ARRAY: statfs
IN: io.files.info.unix.freebsd
TUPLE: freebsd-file-system-info < unix-file-system-info
M: freebsd file-systems ( -- array )
f 0 0 getfsstat dup io-error
- \ statfs <struct-array>
+ <statfs-array>
[ dup byte-length 0 getfsstat io-error ]
[ [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ] bi ;
! Copyright (C) 2008 Doug Coleman.
! 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.uint arrays
-unix.statfs.macosx unix.statvfs.macosx unix.getfsstat.macosx
-io.files.info.unix io.files.info classes.struct struct-arrays ;
+grouping io.encodings.utf8 io.files kernel math sequences system
+unix io.files.unix arrays unix.statfs.macosx unix.statvfs.macosx
+unix.getfsstat.macosx io.files.info.unix io.files.info
+classes.struct specialized-arrays ;
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: statfs64
IN: io.files.info.unix.macosx
TUPLE: macosx-file-system-info < unix-file-system-info
M: macosx file-systems ( -- array )
f <void*> dup 0 getmntinfo64 dup io-error
- [ *void* ] dip \ statfs64 <direct-struct-array>
+ [ *void* ] dip <direct-statfs64-array>
[ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ;
M: macosx new-file-system-info macosx-file-system-info new ;
combinators system io.backend accessors alien.c-types
io.encodings.utf8 alien.strings unix.types io.files.unix
io.files io.files.info unix.statvfs.netbsd unix.getfsstat.netbsd arrays
-grouping sequences io.encodings.utf8 classes.struct struct-arrays
-io.files.info.unix ;
+grouping sequences io.encodings.utf8 classes.struct
+specialized-arrays io.files.info.unix ;
+SPECIALIZED-ARRAY: statvfs
IN: io.files.info.unix.netbsd
TUPLE: netbsd-file-system-info < unix-file-system-info
M: netbsd file-systems ( -- array )
f 0 0 getvfsstat dup io-error
- \ statvfs <struct-array>
+ <statvfs-array>
[ dup byte-length 0 getvfsstat io-error ]
[ [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ] bi ;
combinators io.backend io.files io.files.info io.files.unix kernel math
sequences system unix unix.getfsstat.openbsd grouping
unix.statfs.openbsd unix.statvfs.openbsd unix.types
-arrays io.files.info.unix classes.struct struct-arrays
-io.encodings.utf8 ;
+arrays io.files.info.unix classes.struct
+specialized-arrays io.encodings.utf8 ;
+SPECIALIZED-ARRAY: statvfs
IN: io.files.unix.openbsd
TUPLE: openbsd-file-system-info < unix-file-system-info
M: openbsd file-systems ( -- seq )
f 0 0 getfsstat dup io-error
- \ statfs <struct-array>
+ <statvfs-array>
[ dup byte-length 0 getfsstat io-error ]
[ [ f_mntonname>> utf8 alien>string file-system-info ] { } map-as ] bi ;
USING: accessors kernel system math math.bitwise strings arrays
sequences combinators combinators.short-circuit alien.c-types
vocabs.loader calendar calendar.unix io.files.info
-io.files.types io.backend io.directories unix unix.stat unix.time unix.users
-unix.groups classes.struct struct-arrays ;
+io.files.types io.backend io.directories unix unix.stat
+unix.time unix.users unix.groups classes.struct
+specialized-arrays ;
+SPECIALIZED-ARRAY: timeval
IN: io.files.info.unix
TUPLE: unix-file-system-info < file-system-info
: timestamps>byte-array ( timestamps -- byte-array )
[ [ timestamp>timeval ] [ \ timeval <struct> ] if* ] map
- \ timeval >struct-array ;
+ >timeval-array ;
PRIVATE>
generalizations system alien.strings io.encodings.utf16n
sequences splitting windows.errors fry continuations destructors
calendar ascii combinators.short-circuit locals classes.struct
-specialized-arrays.ushort ;
+specialized-arrays ;
+SPECIALIZED-ARRAY: ushort
IN: io.files.info.windows
:: round-up-to ( n multiple -- n' )
[ first Letter? ]
} 1&& [ 2 head "\\" append ] [ not-absolute-path ] if ;
-M: winnt file-system-info ( path -- file-system-info )
- normalize-path root-directory
+<PRIVATE
+
+: (file-system-info) ( path -- file-system-info )
dup [ volume-information ] [ file-system-space ] bi
\ win32-file-system-info new
swap *ulonglong >>free-space
swap >>mount-point
calculate-file-system-info ;
+PRIVATE>
+
+M: winnt file-system-info ( path -- file-system-info )
+ normalize-path root-directory (file-system-info) ;
+
: volume>paths ( string -- array )
16384 <ushort-array> tuck dup length
0 <uint> dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [
M: winnt file-systems ( -- array )
find-volumes [ volume>paths ] map
concat [
- [ file-system-info ]
+ [ (file-system-info) ]
[ drop \ file-system-info new swap >>mount-point ] recover
] map ;
alien.c-types alien.arrays alien.strings sequences combinators
combinators.short-circuit ascii splitting alien strings assocs
namespaces make accessors tr windows.time windows.shell32
-windows.errors specialized-arrays.ushort classes.struct ;
+windows.errors specialized-arrays classes.struct ;
+SPECIALIZED-ARRAY: ushort
IN: io.files.windows.nt
M: winnt cwd
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations io
-io.backend.windows io.pipes.windows.nt io.pathnames libc io.ports
-windows.types math windows.kernel32
-namespaces make io.launcher kernel sequences windows.errors
-splitting system threads init strings combinators
-io.backend accessors concurrency.flags io.files assocs
-io.files.private windows destructors specialized-arrays.ushort
-specialized-arrays.alien classes classes.struct ;
+io.backend.windows io.pipes.windows.nt io.pathnames libc
+io.ports windows.types math windows.kernel32 namespaces make
+io.launcher kernel sequences windows.errors splitting system
+threads init strings combinators io.backend accessors
+concurrency.flags io.files assocs io.files.private windows
+destructors classes classes.struct specialized-arrays ;
+SPECIALIZED-ARRAY: ushort
+SPECIALIZED-ARRAY: void*
IN: io.launcher.windows
TUPLE: CreateProcess-args
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.alien ;
-IN: io.mmap.alien
-
-<< "void*" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.bool ;
-IN: io.mmap.bool
-
-<< "bool" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.char ;
-IN: io.mmap.char
-
-<< "char" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.double ;
-IN: io.mmap.double
-
-<< "double" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.float ;
-IN: io.mmap.float
-
-<< "float" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: io.mmap functors accessors alien.c-types math kernel
-words fry ;
-IN: io.mmap.functor
-
-SLOT: address
-SLOT: length
-
-: mapped-file>direct ( mapped-file type -- alien length )
- [ [ address>> ] [ length>> ] bi ] dip
- heap-size [ 1 - + ] keep /i ;
-
-FUNCTOR: define-mapped-array ( T -- )
-
-<mapped-A> DEFINES <mapped-${T}-array>
-<A> IS <direct-${T}-array>
-with-mapped-A-file DEFINES with-mapped-${T}-file
-with-mapped-A-file-reader DEFINES with-mapped-${T}-file-reader
-
-WHERE
-
-: <mapped-A> ( mapped-file -- direct-array )
- T mapped-file>direct <A> ; inline
-
-: with-mapped-A-file ( path quot -- )
- '[ <mapped-A> @ ] with-mapped-file ; inline
-
-: with-mapped-A-file-reader ( path quot -- )
- '[ <mapped-A> @ ] with-mapped-file-reader ; inline
-
-;FUNCTOR
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.int ;
-IN: io.mmap.int
-
-<< "int" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.long ;
-IN: io.mmap.long
-
-<< "long" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.longlong ;
-IN: io.mmap.longlong
-
-<< "longlong" define-mapped-array >>
\ No newline at end of file
-USING: io io.mmap io.mmap.char io.files io.files.temp
+USING: io io.mmap io.files io.files.temp
io.directories kernel tools.test continuations sequences
io.encodings.ascii accessors math ;
IN: io.mmap.tests
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
[ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test
-[ ] [ "mmap-test-file.txt" temp-file [ CHAR: 2 0 pick set-nth drop ] with-mapped-char-file ] unit-test
-[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test
-[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file-reader ] unit-test
+[ ] [ "mmap-test-file.txt" temp-file [ "char" <mapped-array> CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" temp-file [ "char" <mapped-array> length ] with-mapped-file ] unit-test
+[ 5 ] [ "mmap-test-file.txt" temp-file [ "char" <mapped-array> length ] with-mapped-file-reader ] unit-test
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
-! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
+! Copyright (C) 2007, 2009 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors io.files io.files.info
io.backend kernel quotations system alien alien.accessors
: <mapped-file> ( path -- mmap )
[ (mapped-file-r/w) ] prepare-mapped-file ;
+: <mapped-array> ( mmap c-type -- direct-array )
+ [ [ address>> ] [ length>> ] bi ] dip
+ [ heap-size /i ] keep
+ <c-direct-array> ; inline
+
HOOK: close-mapped-file io-backend ( mmap -- )
M: mapped-file dispose* ( mmap -- ) close-mapped-file ;
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.short ;
-IN: io.mmap.short
-
-<< "short" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.uchar ;
-IN: io.mmap.uchar
-
-<< "uchar" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.uint ;
-IN: io.mmap.uint
-
-<< "uint" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.ulong ;
-IN: io.mmap.ulong
-
-<< "ulong" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.ulonglong ;
-IN: io.mmap.ulonglong
-
-<< "ulonglong" define-mapped-array >>
\ No newline at end of file
+++ /dev/null
-USING: io.mmap.functor specialized-arrays.ushort ;
-IN: io.mmap.ushort
-
-<< "ushort" define-mapped-array >>
\ No newline at end of file
io.backend.unix io.encodings.utf8 unix.linux.inotify assocs
namespaces make threads continuations init math math.bitwise
sets alien alien.strings alien.c-types vocabs.loader accessors
-system hashtables destructors unix ;
+system hashtables destructors unix classes.struct ;
IN: io.monitors.linux
SYMBOL: watches
] { } make prune ;
: parse-event-name ( event -- name )
- dup inotify-event-len zero?
- [ drop "" ] [ inotify-event-name utf8 alien>string ] if ;
+ dup len>> zero?
+ [ drop "" ] [ name>> utf8 alien>string ] if ;
: parse-file-notify ( buffer -- path changed )
- dup inotify-event-mask ignore-flags? [
+ dup mask>> ignore-flags? [
drop f f
] [
- [ parse-event-name ] [ inotify-event-mask parse-action ] bi
+ [ parse-event-name ] [ mask>> parse-action ] bi
] if ;
: events-exhausted? ( i buffer -- ? )
fill>> >= ;
-: inotify-event@ ( i buffer -- alien )
- ptr>> <displaced-alien> ;
+: inotify-event@ ( i buffer -- inotify-event )
+ ptr>> <displaced-alien> inotify-event memory>struct ;
: next-event ( i buffer -- i buffer )
2dup inotify-event@
- inotify-event-len "inotify-event" heap-size +
+ len>> inotify-event heap-size +
swap [ + ] dip ;
: parse-file-notifications ( i buffer -- )
2dup events-exhausted? [ 2drop ] [
- 2dup inotify-event@ dup inotify-event-wd wd>monitor
+ 2dup inotify-event@ dup wd>> wd>monitor
[ parse-file-notify ] dip queue-change
next-event parse-file-notifications
] if ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system kernel unix math sequences
-io.backend.unix io.ports specialized-arrays.int accessors ;
-IN: io.pipes.unix
+io.backend.unix io.ports specialized-arrays accessors ;
QUALIFIED: io.pipes
+SPECIALIZED-ARRAY: int
+IN: io.pipes.unix
M: unix io.pipes:(pipe) ( -- pair )
2 <int-array>
! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators io io.streams.string json
-kernel math math.parser math.parser.private prettyprint
+kernel math math.parser prettyprint
sequences strings vectors ;
IN: json.reader
PRIVATE>
: json> ( string -- object )
- (json-parser>) ;
\ No newline at end of file
+ (json-parser>) ;
! (c) Joe Groff, see license for details
USING: accessors continuations kernel parser words quotations
-combinators.smart vectors sequences fry ;
+vectors sequences fry ;
IN: literals
<PRIVATE
SYNTAX: $ scan-word expand-literal >vector ;
SYNTAX: $[ parse-quotation with-datastack >vector ;
SYNTAX: ${ \ } [ expand-literals ] parse-literal ;
-
-SYNTAX: $$
- scan-word execute( accum -- accum ) dup pop [ >quotation ] keep
- [ output>sequence ] 2curry call( -- object ) parsed ;
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.float specialized-arrays.double
-specialized-arrays.complex-float specialized-arrays.complex-double
-parser prettyprint.backend prettyprint.custom ascii ;
+parser prettyprint.backend prettyprint.custom ascii
+specialized-arrays ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: double
+SPECIALIZED-ARRAY: complex-float
+SPECIALIZED-ARRAY: complex-double
IN: math.blas.matrices
TUPLE: blas-matrix-base underlying ld rows cols transpose ;
combinators.short-circuit fry kernel math math.blas.ffi
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.complex-float specialized-arrays.complex-double ;
+specialized-arrays ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: double
+SPECIALIZED-ARRAY: complex-float
+SPECIALIZED-ARRAY: 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
+! (c)Joe Groff bsd license
+USING: help help.markup help.syntax quotations ;
+IN: math.floats.env
+
+HELP: fp-exception
+{ $class-description "Symbols of this type represent floating-point exceptions. They are used to get and set the floating-point unit's exception flags (using " { $link fp-exception-flags } " and " { $link set-fp-exception-flags } ") and to control processor traps (using " { $link with-fp-traps } "). The following symbols are defined:"
+{ $list
+{ { $link +fp-invalid-operation+ } " indicates that an invalid floating-point operation occurred, such as taking the square root of a negative number or dividing zero by zero." }
+{ { $link +fp-overflow+ } " indicates that a floating-point operation gave a result larger than the maximum representable value of the type used to perform the calculation." }
+{ { $link +fp-underflow+ } " indicates that a floating-point operation gave a result smaller than the minimum representable normalized value of the type used to perform the calculation." }
+{ { $link +fp-zero-divide+ } " indicates that a floating-point division by zero was attempted." }
+{ { $link +fp-inexact+ } " indicates that a floating-point operation gave an inexact result that needed to be rounded." }
+} } ;
+
+HELP: +fp-invalid-operation+
+{ $class-description "This symbol represents a invalid operation " { $link fp-exception } "." } ;
+HELP: +fp-overflow+
+{ $class-description "This symbol represents an overflow " { $link fp-exception } "." } ;
+HELP: +fp-underflow+
+{ $class-description "This symbol represents an underflow " { $link fp-exception } "." } ;
+HELP: +fp-zero-divide+
+{ $class-description "This symbol represents a division-by-zero " { $link fp-exception } "." } ;
+HELP: +fp-inexact+
+{ $class-description "This symbol represents an inexact result " { $link fp-exception } "." } ;
+
+HELP: fp-rounding-mode
+{ $class-description "Symbols of this type represent floating-point rounding modes. They are passed to the " { $link with-rounding-mode } " word to control how inexact values are calculated when exact results cannot fit in a floating-point type. The following symbols are defined:"
+{ $list
+{ { $link +round-nearest+ } " rounds the exact result to the nearest representable value, using the even value when the result is halfway between its two nearest values." }
+{ { $link +round-zero+ } " rounds the exact result toward zero, that is, down for positive values, and up for negative values." }
+{ { $link +round-down+ } " always rounds the exact result down." }
+{ { $link +round-up+ } " always rounds the exact result up." }
+} } ;
+
+HELP: +round-nearest+
+{ $class-description "This symbol represents the round-to-nearest " { $link fp-rounding-mode } "." } ;
+HELP: +round-zero+
+{ $class-description "This symbol represents the round-toward-zero " { $link fp-rounding-mode } "." } ;
+HELP: +round-down+
+{ $class-description "This symbol represents the round-down " { $link fp-rounding-mode } "." } ;
+HELP: +round-up+
+{ $class-description "This symbol represents the round-up " { $link fp-rounding-mode } "." } ;
+
+HELP: fp-denormal-mode
+{ $class-description "Symbols of this type represent floating-point denormal modes. They are passed to the " { $link with-denormal-mode } " word to control whether denormals are generated as outputs of floating-point operations and how they are treated when given as inputs."
+{ $list
+{ { $link +denormal-keep+ } " causes denormal results to be generated and accepted as inputs as required by IEEE 754." }
+{ { $link +denormal-flush+ } " causes denormal results to be flushed to zero and be treated as zero when given as inputs. This mode may allow floating point operations to give results that are not compliant with the IEEE 754 standard." }
+} } ;
+
+HELP: +denormal-keep+
+{ $class-description "This symbol represents the IEEE 754 compliant keep-denormals " { $link fp-denormal-mode } "." } ;
+HELP: +denormal-flush+
+{ $class-description "This symbol represents the non-IEEE-754-compliant flush-denormals-to-zero " { $link fp-denormal-mode } "." } ;
+
+HELP: fp-exception-flags
+{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $description "Returns the set of floating-point exception flags that have been raised." } ;
+
+HELP: set-fp-exception-flags
+{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $description "Replaces the set of floating-point exception flags with the set specified in " { $snippet "exceptions" } "." }
+{ $notes "On Intel platforms, the legacy x87 floating-point unit does not support setting exception flags, so this word only clears the x87 exception flags. However, the SSE unit's flags are set as expected." } ;
+
+HELP: clear-fp-exception-flags
+{ $description "Clears all of the floating-point exception flags." } ;
+
+HELP: collect-fp-exceptions
+{ $values { "quot" quotation } { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $description "Clears the floating-point exception flags and then calls " { $snippet "quot" } ", returning the set of floating-point exceptions raised during its execution and placing them on the datastack on " { $snippet "quot" } "'s completion." } ;
+
+{ fp-exception-flags set-fp-exception-flags clear-fp-exception-flags collect-fp-exceptions } related-words
+
+HELP: denormal-mode
+{ $values { "mode" fp-denormal-mode } }
+{ $description "Returns the current floating-point denormal mode." } ;
+
+HELP: with-denormal-mode
+{ $values { "mode" fp-denormal-mode } { "quot" quotation } }
+{ $description "Sets the floating-point denormal mode to " { $snippet "mode" } " for the dynamic extent of " { $snippet "quot" } ", restoring the denormal mode to its original value on " { $snippet "quot" } "'s completion." } ;
+
+{ denormal-mode with-denormal-mode } related-words
+
+HELP: rounding-mode
+{ $values { "mode" fp-rounding-mode } }
+{ $description "Returns the current floating-point rounding mode." } ;
+
+HELP: with-rounding-mode
+{ $values { "mode" fp-rounding-mode } { "quot" quotation } }
+{ $description "Sets the floating-point rounding mode to " { $snippet "mode" } " for the dynamic extent of " { $snippet "quot" } ", restoring the rounding mode to its original value on " { $snippet "quot" } "'s completion." } ;
+
+{ rounding-mode with-rounding-mode } related-words
+
+HELP: fp-traps
+{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $description "Returns the set of floating point exceptions with processor traps currently set." } ;
+
+HELP: with-fp-traps
+{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } { "quot" quotation } }
+{ $description "Replaces the floating-point exception mask to enable processor traps to be raised for the set of exception conditions specified in " { $snippet "exceptions" } " for the dynamic extent of " { $snippet "quot" } ", restoring the original exception mask on " { $snippet "quot" } "'s completion." } ;
+
+HELP: without-fp-traps
+{ $values { "quot" quotation } }
+{ $description "Disables all floating-pointer processor traps for the dynamic extent of " { $snippet "quot" } ", restoring the original exception mask on " { $snippet "quot" } "'s completion." } ;
+
+{ fp-traps with-fp-traps without-fp-traps } related-words
+
+ARTICLE: "math.floats.env" "Controlling the floating-point environment"
+"The " { $vocab-link "math.floats.env" } " vocabulary contains words for querying and controlling the floating-point environment."
+$nl
+"Querying and setting exception flags:"
+{ $subsection fp-exception-flags }
+{ $subsection set-fp-exception-flags }
+{ $subsection clear-fp-exception-flags }
+{ $subsection collect-fp-exceptions }
+"Querying and controlling processor traps for floating-point exceptions:"
+{ $subsection fp-traps }
+{ $subsection with-fp-traps }
+{ $subsection without-fp-traps }
+"Querying and controlling the rounding mode and treatment of denormals:"
+{ $subsection rounding-mode }
+{ $subsection with-rounding-mode }
+{ $subsection denormal-mode }
+{ $subsection with-denormal-mode }
+{ $notes "On PowerPC, the above words only modify the scalar FPU's state (in FPSCR); the AltiVec unit is currently unaffected." } ;
+
+ABOUT: "math.floats.env"
--- /dev/null
+USING: kernel math math.floats.env math.floats.env.private
+math.functions math.libm sequences tools.test ;
+IN: math.floats.env.tests
+
+: set-default-fp-env ( -- )
+ { } { } +round-nearest+ +denormal-keep+ set-fp-env ;
+
+! In case the tests screw up the FP env because of bugs in math.floats.env
+set-default-fp-env
+
+[ t ] [
+ [ 1.0 0.0 / drop ] collect-fp-exceptions
+ +fp-zero-divide+ swap member?
+] unit-test
+
+[ t ] [
+ [ 1.0 3.0 / drop ] collect-fp-exceptions
+ +fp-inexact+ swap member?
+] unit-test
+
+[ t ] [
+ [ 1.0e250 1.0e100 * drop ] collect-fp-exceptions
+ +fp-overflow+ swap member?
+] unit-test
+
+[ t ] [
+ [ 1.0e-250 1.0e-100 * drop ] collect-fp-exceptions
+ +fp-underflow+ swap member?
+] unit-test
+
+[ t ] [
+ [ 2.0 100,000.0 ^ drop ] collect-fp-exceptions
+ +fp-overflow+ swap member?
+] unit-test
+
+[ t ] [
+ [ 2.0 -100,000.0 ^ drop ] collect-fp-exceptions
+ +fp-underflow+ swap member?
+] unit-test
+
+[ t ] [
+ [ 0.0 0.0 /f drop ] collect-fp-exceptions
+ +fp-invalid-operation+ swap member?
+] unit-test
+
+[ t ] [
+ [ -1.0 fsqrt drop ] collect-fp-exceptions
+ +fp-invalid-operation+ swap member?
+] unit-test
+
+[
+ HEX: 3fd5,5555,5555,5555
+ HEX: 3fc9,9999,9999,999a
+ HEX: bfc9,9999,9999,999a
+ HEX: bfd5,5555,5555,5555
+] [
+ +round-nearest+ [
+ 1.0 3.0 /f double>bits
+ 1.0 5.0 /f double>bits
+ -1.0 5.0 /f double>bits
+ -1.0 3.0 /f double>bits
+ ] with-rounding-mode
+] unit-test
+
+[
+ HEX: 3fd5,5555,5555,5555
+ HEX: 3fc9,9999,9999,9999
+ HEX: bfc9,9999,9999,999a
+ HEX: bfd5,5555,5555,5556
+] [
+ +round-down+ [
+ 1.0 3.0 /f double>bits
+ 1.0 5.0 /f double>bits
+ -1.0 5.0 /f double>bits
+ -1.0 3.0 /f double>bits
+ ] with-rounding-mode
+] unit-test
+
+[
+ HEX: 3fd5,5555,5555,5556
+ HEX: 3fc9,9999,9999,999a
+ HEX: bfc9,9999,9999,9999
+ HEX: bfd5,5555,5555,5555
+] [
+ +round-up+ [
+ 1.0 3.0 /f double>bits
+ 1.0 5.0 /f double>bits
+ -1.0 5.0 /f double>bits
+ -1.0 3.0 /f double>bits
+ ] with-rounding-mode
+] unit-test
+
+[
+ HEX: 3fd5,5555,5555,5555
+ HEX: 3fc9,9999,9999,9999
+ HEX: bfc9,9999,9999,9999
+ HEX: bfd5,5555,5555,5555
+] [
+ +round-zero+ [
+ 1.0 3.0 /f double>bits
+ 1.0 5.0 /f double>bits
+ -1.0 5.0 /f double>bits
+ -1.0 3.0 /f double>bits
+ ] with-rounding-mode
+] unit-test
+
+! ensure rounding mode is restored to +round-nearest+
+[
+ HEX: 3fd5,5555,5555,5555
+ HEX: 3fc9,9999,9999,999a
+ HEX: bfc9,9999,9999,999a
+ HEX: bfd5,5555,5555,5555
+] [
+ 1.0 3.0 /f double>bits
+ 1.0 5.0 /f double>bits
+ -1.0 5.0 /f double>bits
+ -1.0 3.0 /f double>bits
+] unit-test
+
+[ { +fp-zero-divide+ } [ 1.0 0.0 /f ] with-fp-traps ] must-fail
+[ { +fp-inexact+ } [ 1.0 3.0 /f ] with-fp-traps ] must-fail
+[ { +fp-invalid-operation+ } [ -1.0 fsqrt ] with-fp-traps ] must-fail
+[ { +fp-overflow+ } [ 2.0 100,000.0 ^ ] with-fp-traps ] must-fail
+[ { +fp-underflow+ } [ 2.0 -100,000.0 ^ ] with-fp-traps ] must-fail
+
+! Ensure traps get cleared
+[ 1/0. ] [ 1.0 0.0 /f ] unit-test
+
+! Ensure state is back to normal
+[ +round-nearest+ ] [ rounding-mode ] unit-test
+[ +denormal-keep+ ] [ denormal-mode ] unit-test
+[ { } ] [ fp-traps ] unit-test
+
+! In case the tests screw up the FP env because of bugs in math.floats.env
+set-default-fp-env
+
--- /dev/null
+! (c)Joe Groff bsd license
+USING: alien.syntax arrays assocs biassocs combinators continuations
+generalizations kernel literals locals math math.bitwise
+sequences sets system vocabs.loader ;
+IN: math.floats.env
+
+SINGLETONS:
+ +fp-invalid-operation+
+ +fp-overflow+
+ +fp-underflow+
+ +fp-zero-divide+
+ +fp-inexact+ ;
+
+UNION: fp-exception
+ +fp-invalid-operation+
+ +fp-overflow+
+ +fp-underflow+
+ +fp-zero-divide+
+ +fp-inexact+ ;
+
+SINGLETONS:
+ +round-nearest+
+ +round-down+
+ +round-up+
+ +round-zero+ ;
+
+UNION: fp-rounding-mode
+ +round-nearest+
+ +round-down+
+ +round-up+
+ +round-zero+ ;
+
+SINGLETONS:
+ +denormal-keep+
+ +denormal-flush+ ;
+
+UNION: fp-denormal-mode
+ +denormal-keep+
+ +denormal-flush+ ;
+
+<PRIVATE
+
+HOOK: (fp-env-registers) cpu ( -- registers )
+
+: fp-env-register ( -- register ) (fp-env-registers) first ;
+
+:: mask> ( bits assoc -- symbols )
+ assoc [| k v | bits v mask zero? not ] assoc-filter keys ;
+: >mask ( symbols assoc -- bits )
+ over empty?
+ [ 2drop 0 ]
+ [ [ at ] curry [ bitor ] map-reduce ] if ;
+
+: remask ( x new-bits mask-bits -- x' )
+ [ unmask ] [ mask ] bi-curry bi* bitor ; inline
+
+GENERIC: (set-fp-env-register) ( fp-env -- )
+
+GENERIC: (get-exception-flags) ( fp-env -- exceptions )
+GENERIC# (set-exception-flags) 1 ( fp-env exceptions -- fp-env )
+
+GENERIC: (get-fp-traps) ( fp-env -- exceptions )
+GENERIC# (set-fp-traps) 1 ( fp-env exceptions -- fp-env )
+
+GENERIC: (get-rounding-mode) ( fp-env -- mode )
+GENERIC# (set-rounding-mode) 1 ( fp-env mode -- fp-env )
+
+GENERIC: (get-denormal-mode) ( fp-env -- mode )
+GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env )
+
+: change-fp-env-registers ( quot -- )
+ (fp-env-registers) swap [ (set-fp-env-register) ] compose each ; inline
+
+: set-fp-traps ( exceptions -- ) [ (set-fp-traps) ] curry change-fp-env-registers ;
+: set-rounding-mode ( mode -- ) [ (set-rounding-mode) ] curry change-fp-env-registers ;
+: set-denormal-mode ( mode -- ) [ (set-denormal-mode) ] curry change-fp-env-registers ;
+
+: get-fp-env ( -- exception-flags fp-traps rounding-mode denormal-mode )
+ fp-env-register {
+ [ (get-exception-flags) ]
+ [ (get-fp-traps) ]
+ [ (get-rounding-mode) ]
+ [ (get-denormal-mode) ]
+ } cleave ;
+
+: set-fp-env ( exception-flags fp-traps rounding-mode denormal-mode -- )
+ [
+ {
+ [ [ (set-exception-flags) ] when* ]
+ [ [ (set-fp-traps) ] when* ]
+ [ [ (set-rounding-mode) ] when* ]
+ [ [ (set-denormal-mode) ] when* ]
+ } spread
+ ] 4 ncurry change-fp-env-registers ;
+
+PRIVATE>
+
+: fp-exception-flags ( -- exceptions )
+ (fp-env-registers) [ (get-exception-flags) ] [ union ] map-reduce >array ; inline
+: set-fp-exception-flags ( exceptions -- )
+ [ (set-exception-flags) ] curry change-fp-env-registers ; inline
+: clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline
+
+: collect-fp-exceptions ( quot -- exceptions )
+ clear-fp-exception-flags call fp-exception-flags ; inline
+
+: denormal-mode ( -- mode ) fp-env-register (get-denormal-mode) ;
+
+:: with-denormal-mode ( mode quot -- )
+ denormal-mode :> orig
+ mode set-denormal-mode
+ quot [ orig set-denormal-mode ] [ ] cleanup ; inline
+
+: rounding-mode ( -- mode ) fp-env-register (get-rounding-mode) ;
+
+:: with-rounding-mode ( mode quot -- )
+ rounding-mode :> orig
+ mode set-rounding-mode
+ quot [ orig set-rounding-mode ] [ ] cleanup ; inline
+
+: fp-traps ( -- exceptions )
+ (fp-env-registers) [ (get-fp-traps) ] [ union ] map-reduce >array ; inline
+
+:: with-fp-traps ( exceptions quot -- )
+ fp-traps :> orig
+ exceptions set-fp-traps
+ quot [ orig set-fp-traps ] [ ] cleanup ; inline
+
+: without-fp-traps ( quot -- )
+ { } swap with-fp-traps ; inline
+
+<< {
+ { [ cpu x86? ] [ "math.floats.env.x86" require ] }
+ { [ cpu ppc? ] [ "math.floats.env.ppc" require ] }
+ [ "CPU architecture unsupported by math.floats.env" throw ]
+} cond >>
+
--- /dev/null
+USING: accessors alien.syntax arrays assocs biassocs
+classes.struct combinators kernel literals math math.bitwise
+math.floats.env math.floats.env.private system ;
+IN: math.floats.env.ppc
+
+STRUCT: ppc-fpu-env
+ { padding uint }
+ { fpcsr uint } ;
+
+! defined in the vm, cpu-ppc*.S
+FUNCTION: void get_ppc_fpu_env ( ppc-fpu-env* env ) ;
+FUNCTION: void set_ppc_fpu_env ( ppc-fpu-env* env ) ;
+
+: <ppc-fpu-env> ( -- ppc-fpu-env )
+ ppc-fpu-env (struct)
+ [ get_ppc_fpu_env ] keep ;
+
+M: ppc-fpu-env (set-fp-env-register)
+ set_ppc_fpu_env ;
+
+M: ppc (fp-env-registers)
+ <ppc-fpu-env> 1array ;
+
+CONSTANT: ppc-exception-flag-bits HEX: 3e00,0000
+CONSTANT: ppc-exception-flag>bit
+ H{
+ { +fp-invalid-operation+ HEX: 2000,0000 }
+ { +fp-overflow+ HEX: 1000,0000 }
+ { +fp-underflow+ HEX: 0800,0000 }
+ { +fp-zero-divide+ HEX: 0400,0000 }
+ { +fp-inexact+ HEX: 0200,0000 }
+ }
+
+CONSTANT: ppc-fp-traps-bits HEX: f80
+CONSTANT: ppc-fp-traps>bit
+ H{
+ { +fp-invalid-operation+ HEX: 8000 }
+ { +fp-overflow+ HEX: 4000 }
+ { +fp-underflow+ HEX: 2000 }
+ { +fp-zero-divide+ HEX: 1000 }
+ { +fp-inexact+ HEX: 0800 }
+ }
+
+CONSTANT: ppc-rounding-mode-bits HEX: 3
+CONSTANT: ppc-rounding-mode>bit
+ $[ H{
+ { +round-nearest+ HEX: 0 }
+ { +round-zero+ HEX: 1 }
+ { +round-up+ HEX: 2 }
+ { +round-down+ HEX: 3 }
+ } >biassoc ]
+
+CONSTANT: ppc-denormal-mode-bits HEX: 4
+
+M: ppc-fpu-env (get-exception-flags) ( register -- exceptions )
+ fpcsr>> ppc-exception-flag>bit mask> ; inline
+M: ppc-fpu-env (set-exception-flags) ( register exceptions -- register' )
+ [ ppc-exception-flag>bit >mask ppc-exception-flag-bits remask ] curry change-fpcsr ; inline
+
+M: ppc-fpu-env (get-fp-traps) ( register -- exceptions )
+ fpcsr>> not ppc-fp-traps>bit mask> ; inline
+M: ppc-fpu-env (set-fp-traps) ( register exceptions -- register' )
+ [ ppc-fp-traps>bit >mask not ppc-fp-traps-bits remask ] curry change-fpcsr ; inline
+
+M: ppc-fpu-env (get-rounding-mode) ( register -- mode )
+ fpcsr>> ppc-rounding-mode-bits mask ppc-rounding-mode>bit value-at ; inline
+M: ppc-fpu-env (set-rounding-mode) ( register mode -- register' )
+ [ ppc-rounding-mode>bit at ppc-rounding-mode-bits remask ] curry change-fpcsr ; inline
+
+M: ppc-fpu-env (get-denormal-mode) ( register -- mode )
+ fpcsr>> ppc-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
+M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' )
+ [
+ {
+ { +denormal-keep+ [ ppc-denormal-mode-bits unmask ] }
+ { +denormal-flush+ [ ppc-denormal-mode-bits bitor ] }
+ } case
+ ] curry change-fpcsr ; inline
+
--- /dev/null
+unportable
--- /dev/null
+IEEE 754 floating-point environment querying and control (exceptions, rounding mode, and denormals)
--- /dev/null
+unportable
--- /dev/null
+USING: accessors alien.syntax arrays assocs biassocs
+classes.struct combinators cpu.x86.features kernel literals
+math math.bitwise math.floats.env math.floats.env.private
+system ;
+IN: math.floats.env.x86
+
+STRUCT: sse-env
+ { mxcsr uint } ;
+
+STRUCT: x87-env
+ { status ushort }
+ { control ushort } ;
+
+! defined in the vm, cpu-x86*.S
+FUNCTION: void get_sse_env ( sse-env* env ) ;
+FUNCTION: void set_sse_env ( sse-env* env ) ;
+
+FUNCTION: void get_x87_env ( x87-env* env ) ;
+FUNCTION: void set_x87_env ( x87-env* env ) ;
+
+: <sse-env> ( -- sse-env )
+ sse-env (struct) [ get_sse_env ] keep ;
+
+M: sse-env (set-fp-env-register)
+ set_sse_env ;
+
+: <x87-env> ( -- x87-env )
+ x87-env (struct) [ get_x87_env ] keep ;
+
+M: x87-env (set-fp-env-register)
+ set_x87_env ;
+
+M: x86 (fp-env-registers)
+ sse-version 20 >=
+ [ <sse-env> <x87-env> 2array ]
+ [ <x87-env> 1array ] if ;
+
+CONSTANT: sse-exception-flag-bits HEX: 3f
+CONSTANT: sse-exception-flag>bit
+ H{
+ { +fp-invalid-operation+ HEX: 01 }
+ { +fp-overflow+ HEX: 08 }
+ { +fp-underflow+ HEX: 10 }
+ { +fp-zero-divide+ HEX: 04 }
+ { +fp-inexact+ HEX: 20 }
+ }
+
+CONSTANT: sse-fp-traps-bits HEX: 1f80
+CONSTANT: sse-fp-traps>bit
+ H{
+ { +fp-invalid-operation+ HEX: 0080 }
+ { +fp-overflow+ HEX: 0400 }
+ { +fp-underflow+ HEX: 0800 }
+ { +fp-zero-divide+ HEX: 0200 }
+ { +fp-inexact+ HEX: 1000 }
+ }
+
+CONSTANT: sse-rounding-mode-bits HEX: 6000
+CONSTANT: sse-rounding-mode>bit
+ $[ H{
+ { +round-nearest+ HEX: 0000 }
+ { +round-down+ HEX: 2000 }
+ { +round-up+ HEX: 4000 }
+ { +round-zero+ HEX: 6000 }
+ } >biassoc ]
+
+CONSTANT: sse-denormal-mode-bits HEX: 8040
+
+M: sse-env (get-exception-flags) ( register -- exceptions )
+ mxcsr>> sse-exception-flag>bit mask> ; inline
+M: sse-env (set-exception-flags) ( register exceptions -- register' )
+ [ sse-exception-flag>bit >mask sse-exception-flag-bits remask ] curry change-mxcsr ; inline
+
+M: sse-env (get-fp-traps) ( register -- exceptions )
+ mxcsr>> bitnot sse-fp-traps>bit mask> ; inline
+M: sse-env (set-fp-traps) ( register exceptions -- register' )
+ [ sse-fp-traps>bit >mask bitnot sse-fp-traps-bits remask ] curry change-mxcsr ; inline
+
+M: sse-env (get-rounding-mode) ( register -- mode )
+ mxcsr>> sse-rounding-mode-bits mask sse-rounding-mode>bit value-at ; inline
+M: sse-env (set-rounding-mode) ( register mode -- register' )
+ [ sse-rounding-mode>bit at sse-rounding-mode-bits remask ] curry change-mxcsr ; inline
+
+M: sse-env (get-denormal-mode) ( register -- mode )
+ mxcsr>> sse-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
+M: sse-env (set-denormal-mode) ( register mode -- register' )
+ [
+ {
+ { +denormal-keep+ [ sse-denormal-mode-bits unmask ] }
+ { +denormal-flush+ [ sse-denormal-mode-bits bitor ] }
+ } case
+ ] curry change-mxcsr ; inline
+
+CONSTANT: x87-exception-bits HEX: 3f
+CONSTANT: x87-exception>bit
+ H{
+ { +fp-invalid-operation+ HEX: 01 }
+ { +fp-overflow+ HEX: 08 }
+ { +fp-underflow+ HEX: 10 }
+ { +fp-zero-divide+ HEX: 04 }
+ { +fp-inexact+ HEX: 20 }
+ }
+
+CONSTANT: x87-rounding-mode-bits HEX: 0c00
+CONSTANT: x87-rounding-mode>bit
+ $[ H{
+ { +round-nearest+ HEX: 0000 }
+ { +round-down+ HEX: 0400 }
+ { +round-up+ HEX: 0800 }
+ { +round-zero+ HEX: 0c00 }
+ } >biassoc ]
+
+M: x87-env (get-exception-flags) ( register -- exceptions )
+ status>> x87-exception>bit mask> ; inline
+M: x87-env (set-exception-flags) ( register exceptions -- register' )
+ drop ;
+
+M: x87-env (get-fp-traps) ( register -- exceptions )
+ control>> bitnot x87-exception>bit mask> ; inline
+M: x87-env (set-fp-traps) ( register exceptions -- register' )
+ [ x87-exception>bit >mask bitnot x87-exception-bits remask ] curry change-control ; inline
+
+M: x87-env (get-rounding-mode) ( register -- mode )
+ control>> x87-rounding-mode-bits mask x87-rounding-mode>bit value-at ; inline
+M: x87-env (set-rounding-mode) ( register mode -- register' )
+ [ x87-rounding-mode>bit at x87-rounding-mode-bits remask ] curry change-control ; inline
+
+M: x87-env (get-denormal-mode) ( register -- mode )
+ drop +denormal-keep+ ; inline
+M: x87-env (set-denormal-mode) ( register mode -- register' )
+ drop ;
+
{ $subsection exp }
{ $subsection cis }
{ $subsection log }
+{ $subsection log1+ }
{ $subsection log10 }
"Raising a number to a power:"
{ $subsection ^ }
{ $values { "x" number } { "y" number } }
{ $description "Natural logarithm function. Outputs negative infinity if " { $snippet "x" } " is 0." } ;
+HELP: log1+
+{ $values { "x" number } { "y" number } }
+{ $description "Takes the natural logarithm of " { $snippet "1 + x" } ". Outputs negative infinity if " { $snippet "1 + x" } " is zero. This word may be more accurate than " { $snippet "1 + log" } " for very small values of " { $snippet "x" } "." } ;
+
HELP: log10
{ $values { "x" number } { "y" number } }
{ $description "Logarithm function base 10. Outputs negative infinity if " { $snippet "x" } " is 0." } ;
M: real log >float log ; inline
-M: complex log >polar swap flog swap rect> ; inline
+M: complex log >polar [ flog ] dip rect> ; inline
+
+GENERIC: log1+ ( x -- y )
+
+M: object log1+ 1 + log ; inline
+
+M: float log1+ dup -1.0 >= [ flog1+ ] [ 1.0 + 0.0 rect> log ] if ; inline
: 10^ ( x -- y ) 10 swap ^ ; inline
"double" "libm" "sqrt" { "double" } alien-invoke ;
! Windows doesn't have these...
+: flog1+ ( x -- y )
+ "double" "libm" "log1p" { "double" } alien-invoke ;
+
: facosh ( x -- y )
"double" "libm" "acosh" { "double" } alien-invoke ;
{ { 13 4253 15823 32472893749823741 } } [ 28408516453955558205925627 factors ] unit-test
{ { 1 2 3 4 6 8 12 24 } } [ 24 divisors ] unit-test
{ 24 } [ 360 divisors length ] unit-test
+{ { 1 } } [ 1 divisors ] unit-test
} cond ; foldable
: divisors ( n -- seq )
- group-factors [ first2 [0,b] [ ^ ] with map ] map
- [ product ] product-map natural-sort ;
+ dup 1 = [
+ 1array
+ ] [
+ group-factors [ first2 [0,b] [ ^ ] with map ] map
+ [ product ] product-map natural-sort
+ ] if ;
: (find-relative-prime) ( n guess -- p )
over 1 <= [ over no-relative-prime ] when
dup 1 <= [ drop 3 ] when
- 2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
+ [ 2dup coprime? ] [ 2 + ] until nip ;
PRIVATE>
--- /dev/null
+USING: help.markup help.syntax math.rectangles ;
+IN: math.rectangles.positioning
+
+HELP: popup-rect
+{ $values { "visible-rect" rect } { "popup-dim" "a pair of real numbers" } { "screen-dim" "a pair of real numbers" } { "rect" rect } }
+{ $description "Calculates the position of a popup with a heuristic:"
+ { $list
+ { "The new rectangle must fit inside " { $snippet "screen-dim" } }
+ { "The new rectangle must not obscure " { $snippet "visible-rect" } }
+ { "The child must otherwise be as close as possible to the edges of " { $snippet "visible-rect" } }
+ }
+ "For example, when displaying a menu, " { $snippet "visible-rect" } " is a single point at the mouse location, and when displaying a completion popup, " { $snippet "visible-rect" } " contains the bounds of the text element being completed."
+} ;
IN: math.rectangles.positioning.tests
[ T{ rect f { 0 1 } { 30 30 } } ] [
- { 0 0 } { 1 1 } <rect>
+ T{ rect f { 0 0 } { 1 1 } }
{ 30 30 }
{ 100 100 }
popup-rect
] unit-test
[ T{ rect f { 10 21 } { 30 30 } } ] [
- { 10 20 } { 1 1 } <rect>
+ T{ rect f { 10 20 } { 1 1 } }
{ 30 30 }
{ 100 100 }
popup-rect
] unit-test
[ T{ rect f { 10 30 } { 30 30 } } ] [
- { 10 20 } { 1 10 } <rect>
+ T{ rect f { 10 20 } { 1 10 } }
{ 30 30 }
{ 100 100 }
popup-rect
] unit-test
[ T{ rect f { 20 20 } { 80 30 } } ] [
- { 40 10 } { 1 10 } <rect>
+ T{ rect f { 40 10 } { 1 10 } }
{ 80 30 }
{ 100 100 }
popup-rect
] unit-test
[ T{ rect f { 50 20 } { 50 50 } } ] [
- { 50 70 } { 0 0 } <rect>
+ T{ rect f { 50 70 } { 0 0 } }
{ 50 50 }
{ 100 100 }
popup-rect
] unit-test
[ T{ rect f { 0 20 } { 50 50 } } ] [
- { -50 70 } { 0 0 } <rect>
+ T{ rect f { -50 70 } { 0 0 } }
{ 50 50 }
{ 100 100 }
popup-rect
] unit-test
[ T{ rect f { 0 50 } { 50 50 } } ] [
- { 0 50 } { 0 0 } <rect>
+ T{ rect f { 0 50 } { 0 0 } }
{ 50 60 }
{ 100 100 }
popup-rect
+] unit-test
+
+[ T{ rect f { 0 90 } { 10 10 } } ] [
+ T{ rect f { 0 1000 } { 0 0 } }
+ { 10 10 }
+ { 100 100 }
+ popup-rect
] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel accessors math math.vectors
-math.rectangles math.order arrays locals
+math.rectangles math.order arrays locals fry
combinators.short-circuit ;
IN: math.rectangles.positioning
! Some geometry code for positioning popups and menus
! in a semi-intelligent manner
+<PRIVATE
+
+: adjust-visible-rect ( visible-rect popup-dim screen-dim -- visible-rect' )
+ [ drop clone ] dip '[ _ vmin ] change-loc ;
+
: popup-x ( visible-rect popup-dim screen-dim -- x )
[ loc>> first ] 2dip swap [ first ] bi@ - min 0 max ;
:: popup-dim ( loc popup-dim screen-dim -- dim )
screen-dim loc v- popup-dim vmin ;
+PRIVATE>
+
: popup-rect ( visible-rect popup-dim screen-dim -- rect )
+ [ adjust-visible-rect ] 2keep
[ popup-loc dup ] 2keep popup-dim <rect> ;
\ No newline at end of file
--- /dev/null
+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 combinators ;
+SPECIALIZED-ARRAY: float
+IN: math.vectors.simd.alien.tests
+
+! 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
+system ;
+
+[ 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; only on x86
+cpu x86? [
+ [ 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
+] when
--- /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 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
IN: math.vectors.specialization.tests
USING: compiler.tree.debugger math.vectors tools.test kernel
-kernel.private math specialized-arrays.double
-specialized-arrays.complex-float
-specialized-arrays.float ;
+kernel.private math specialized-arrays ;
+SPECIALIZED-ARRAY: double
+SPECIALIZED-ARRAY: complex-float
+SPECIALIZED-ARRAY: float
[ V{ t } ] [
[ { double-array double-array } declare distance 0.0 < not ] final-literals
! Copyright (C) 2009 Slava Pestov.
! 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
-compiler.tree.propagation.info ;
+USING: alien.c-types words kernel make sequences effects
+kernel.private accessors combinators math math.intervals
+math.vectors namespaces assocs fry splitting classes.algebra
+generalizations locals compiler.tree.propagation.info ;
IN: math.vectors.specialization
SYMBOLS: -> +vector+ +scalar+ +nonnegative+ ;
{ vmin { +vector+ +vector+ -> +vector+ } }
{ vneg { +vector+ -> +vector+ } }
{ vtruncate { +vector+ -> +vector+ } }
+ { sum { +vector+ -> +scalar+ } }
}
-SYMBOL: specializations
+PREDICATE: vector-word < word vector-words key? ;
-specializations [ vector-words keys [ V{ } clone ] H{ } map>assoc ] initialize
+: specializations ( word -- assoc )
+ dup "specializations" word-prop
+ [ ] [ V{ } clone [ "specializations" set-word-prop ] keep ] ?if ;
+
+M: vector-word subwords specializations values [ word? ] filter ;
: add-specialization ( new-word signature word -- )
- specializations get at set-at ;
+ specializations set-at ;
: word-schema ( word -- schema ) vector-words at ;
: 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 ;
+
+:: 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 -- )
- [ vector-words keys ] 2dip
- '[
- [ _ _ specialize-vector-word ] keep
- [ dup input-signature ] dip
- add-specialization
- ] each ;
+:: specialize-vector-words ( array-type elt-type simd -- )
+ elt-type number class<= [
+ vector-words keys [
+ [ array-type elt-type simd specialize-vector-word ]
+ [ array-type elt-type input-signature ]
+ [ ]
+ tri add-specialization
+ ] each
+ ] when ;
: find-specialization ( classes word -- word/f )
- specializations get at
+ specializations
[ first [ class<= ] 2all? ] with find
swap [ second ] when ;
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- }
math.parser opengl.gl combinators combinators.smart arrays
sequences splitting words byte-arrays assocs vocabs
colors colors.constants accessors generalizations locals fry
-specialized-arrays.float specialized-arrays.uint ;
+specialized-arrays ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: uint
IN: opengl
: gl-color ( color -- ) >rgba-components glColor4d ; inline
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
assocs alien alien.strings libc opengl math sequences combinators
-macros arrays io.encodings.ascii fry specialized-arrays.uint
+macros arrays io.encodings.ascii fry specialized-arrays
destructors accessors ;
+SPECIALIZED-ARRAY: uint
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs cache colors.constants destructors kernel
-opengl opengl.gl opengl.capabilities combinators images
-images.tesselation grouping specialized-arrays.float sequences math
-math.vectors math.matrices generalizations fry arrays namespaces
-system locals literals ;
+USING: accessors assocs cache colors.constants destructors
+kernel opengl opengl.gl opengl.capabilities combinators images
+images.tesselation grouping sequences math math.vectors
+math.matrices generalizations fry arrays namespaces system
+locals literals specialized-arrays ;
+SPECIALIZED-ARRAY: float
IN: opengl.textures
SYMBOL: non-power-of-2-textures?
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays byte-arrays byte-vectors continuations
-generic hashtables assocs kernel math namespaces make sequences
-strings sbufs vectors words prettyprint.config prettyprint.custom
-prettyprint.sections quotations io io.pathnames io.styles math.parser
-effects classes.tuple math.order classes.tuple.private classes
-combinators colors ;
+USING: accessors arrays assocs byte-arrays byte-vectors classes
+classes.tuple classes.tuple.private colors colors.constants
+combinators continuations effects generic hashtables io
+io.pathnames io.styles kernel make math math.order math.parser
+namespaces prettyprint.config prettyprint.custom
+prettyprint.sections prettyprint.stylesheet quotations sbufs
+sequences strings vectors words words.symbol ;
IN: prettyprint.backend
M: effect pprint* effect>string "(" ")" surround text ;
?effect-height 0 < [ end-group ] when ;
! Atoms
-: word-style ( word -- style )
- dup "word-style" word-prop >hashtable [
- [
- [ presented set ]
- [
- [ parsing-word? ] [ delimiter? ] [ t eq? ] tri or or
- [ bold font-style set ] when
- ] bi
- ] bind
- ] keep ;
-
: word-name* ( word -- str )
name>> "( no name )" or ;
M: f pprint* drop \ f pprint-word ;
+: pprint-effect ( effect -- )
+ [ effect>string ] [ effect-style ] bi styled-text ;
+
! Strings
: ch>ascii-escape ( ch -- str )
H{
] when
] when ;
-: string-style ( obj -- hash )
- [
- presented set
- T{ rgba f 0.3 0.3 0.3 1.0 } foreground set
- ] H{ } make-assoc ;
-
: unparse-string ( str prefix suffix -- str )
[ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ;
--- /dev/null
+! Copyright (C) 2009 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: colors.constants hashtables io.styles kernel namespaces
+words words.symbol ;
+IN: prettyprint.stylesheet
+
+: word-style ( word -- style )
+ dup "word-style" word-prop >hashtable [
+ [
+ [ presented set ] [
+ [ parsing-word? ] [ delimiter? ] [ symbol? ] tri
+ or or [ COLOR: DarkSlateGray ] [ COLOR: black ] if
+ foreground set
+ ] bi
+ ] bind
+ ] keep ;
+
+: string-style ( obj -- style )
+ [
+ presented set
+ COLOR: LightSalmon4 foreground set
+ ] H{ } make-assoc ;
+
+: vocab-style ( vocab -- style )
+ [
+ presented set
+ COLOR: cornsilk4 foreground set
+ ] H{ } make-assoc ;
+
+: effect-style ( effect -- style )
+ [
+ presented set
+ COLOR: DarkGreen foreground set
+ ] H{ } make-assoc ;
\ No newline at end of file
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
USING: kernel math namespaces sequences sequences.private system
init accessors math.ranges random math.bitwise combinators
-specialized-arrays.uint fry ;
+specialized-arrays fry ;
+SPECIALIZED-ARRAY: uint
IN: random.mersenne-twister
<PRIVATE
io.streams.string io.styles kernel make namespaces prettyprint
prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections sequences sets sorting strings summary words
-words.symbol words.constant words.alias vocabs ;
+words.symbol words.constant words.alias vocabs slots ;
IN: see
GENERIC: synopsis* ( defspec -- )
: stack-effect. ( word -- )
[ print-stack-effect? ] [ stack-effect ] bi and
- [ effect>string comment. ] when* ;
+ [ pprint-effect ] when* ;
<PRIVATE
] tri ;
: seeing-implementors ( class -- seq )
- dup implementors [ method ] with map natural-sort ;
+ dup implementors
+ [ [ reader? ] [ writer? ] bi or not ] filter
+ [ method ] with map
+ natural-sort ;
: seeing-methods ( generic -- seq )
"methods" word-prop values natural-sort ;
HELP: complex-sequence
{ $class-description "Sequence wrapper class that transforms a sequence of " { $link real } " number values into a sequence of " { $link complex } " values, treating the underlying sequence as pairs of alternating real and imaginary values." }
{ $examples { $example <"
-USING: prettyprint
-specialized-arrays.double sequences.complex
-sequences arrays ;
+USING: prettyprint specialized-arrays
+sequences.complex sequences arrays ;
+SPECIALIZED-ARRAY: double
double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> >array .
"> "{ C{ 1.0 -1.0 } C{ -2.0 2.0 } C{ 3.0 0.0 } }" } } ;
{ $values { "sequence" sequence } { "complex-sequence" complex-sequence } }
{ $description "Wraps " { $snippet "sequence" } " in a " { $link complex-sequence } "." }
{ $examples { $example <"
-USING: prettyprint
-specialized-arrays.double sequences.complex
-sequences arrays ;
+USING: prettyprint specialized-arrays
+sequences.complex sequences arrays ;
+SPECIALIZED-ARRAY: double
double-array{ 1.0 -1.0 -2.0 2.0 3.0 0.0 } <complex-sequence> second .
"> "C{ -2.0 2.0 }" } } ;
-USING: specialized-arrays.float sequences.complex
+USING: specialized-arrays sequences.complex
kernel sequences tools.test arrays accessors ;
+SPECIALIZED-ARRAY: float
IN: sequences.complex.tests
: test-array ( -- x )
! See http://factorcode.org/license.txt for BSD license.
!
USING: tools.test kernel serialize io io.streams.byte-array
-alien arrays byte-arrays bit-arrays specialized-arrays.double
+alien arrays byte-arrays bit-arrays specialized-arrays
sequences math prettyprint parser classes math.constants
io.encodings.binary random assocs serialize.private ;
+SPECIALIZED-ARRAY: double
IN: serialize.tests
: test-serialize-cell ( a -- ? )
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.alien
-
-<< "void*" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.bool
-
-<< "bool" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.char
-
-<< "char" define-array >>
\ No newline at end of file
+++ /dev/null
-USING: kernel sequences specialized-arrays.complex-double tools.test ;
-IN: specialized-arrays.complex-double.tests
-
-[ C{ 3.0 2.0 } ]
-[ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } second ] unit-test
-
-[ C{ 1.0 0.0 } ]
-[ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } first ] unit-test
-
-[ complex-double-array{ 1.0 C{ 6.0 -7.0 } 5.0 } ] [
- complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 }
- dup [ C{ 6.0 -7.0 } 1 ] dip set-nth
-] unit-test
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.complex-double
-
-<< "complex-double" define-array >>
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.complex-float
-
-<< "complex-float" define-array >>
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.double
-
-<< "double" define-array >>
-
-! Specializer hints. These should really be generalized, and placed
-! somewhere else
-USING: hints math.vectors arrays kernel math accessors sequences ;
-
-HINTS: <double-array> { 2 } { 3 } ;
-
-HINTS: (double-array) { 2 } { 3 } ;
-
-! Type functions
-USING: words classes.algebra compiler.tree.propagation.info
-math.intervals ;
-
-\ norm-sq [
- class>> double-array class<= [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
-] "outputs" set-word-prop
-
-\ distance [
- [ class>> double-array class<= ] both?
- [ float 0. 1/0. [a,b] <class/interval-info> ] [ object-info ] if
-] "outputs" set-word-prop
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.float
-
-<< "float" define-array >>
\ No newline at end of file
+++ /dev/null
-! 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 specialized-arrays ;
-IN: specialized-arrays.functor
-
-ERROR: bad-byte-array-length byte-array type ;
-
-M: bad-byte-array-length summary
- drop "Byte array length doesn't divide type width" ;
-
-: (underlying) ( n c-type -- array )
- heap-size * (byte-array) ; inline
-
-: <underlying> ( n type -- array )
- heap-size * <byte-array> ; inline
-
-FUNCTOR: define-array ( T -- )
-
-A DEFINES-CLASS ${T}-array
-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 ]
-
-WHERE
-
-MIXIN: S
-
-TUPLE: A
-{ underlying c-ptr read-only }
-{ length array-capacity read-only } ;
-
-: <direct-A> ( alien len -- specialized-array ) A boa ; inline
-
-: <A> ( n -- specialized-array ) [ T <underlying> ] keep <direct-A> ; 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
- <direct-A> ; inline
-
-M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline
-
-M: A length length>> ; inline
-
-M: A nth-unsafe underlying>> NTH call ; inline
-
-M: A set-nth-unsafe underlying>> SET-NTH call ; inline
-
-: >A ( seq -- specialized-array ) A new clone-like ;
-
-M: A like drop dup A instance? [ >A ] unless ; inline
-
-M: A new-sequence drop (A) ; inline
-
-M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
-
-M: A resize
- [
- [ T heap-size * ] [ underlying>> ] bi*
- resize-byte-array
- ] [ drop ] 2bi
- <direct-A> ; inline
-
-M: A byte-length underlying>> length ; inline
-M: A pprint-delims drop \ A{ \ } ;
-M: A >pprint-sequence ;
-
-SYNTAX: A{ \ } [ >A ] parse-literal ;
-SYNTAX: A@ scan-object scan-object <direct-A> parsed ;
-
-INSTANCE: A specialized-array
-
-A T c-type-boxed-class specialize-vector-words
-
-T c-type
- \ A >>array-class
- \ <A> >>array-constructor
- \ (A) >>(array)-constructor
- \ <direct-A> >>direct-array-constructor
- drop
-
-;FUNCTOR
+++ /dev/null
-Code generation for specialized arrays
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.int
-
-<< "int" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.long
-
-<< "long" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.longlong
-
-<< "longlong" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.alien
-
-<< "ptrdiff_t" define-array >>
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.short
-
-<< "short" define-array >>
\ No newline at end of file
-USING: help.markup help.syntax byte-arrays ;
+USING: help.markup help.syntax byte-arrays alien ;
IN: specialized-arrays
-ARTICLE: "specialized-arrays" "Specialized arrays"
-"The " { $vocab-link "specialized-arrays" } " vocabulary implements fixed-length sequence types for storing machine values in a space-efficient manner without boxing."
-$nl
-"For each primitive C type " { $snippet "T" } ", a set of words are defined in the vocabulary named " { $snippet "specialized-arrays.T" } ":"
+HELP: SPECIALIZED-ARRAY:
+{ $syntax "SPECIALIZED-ARRAY: type" }
+{ $values { "type" "a C type" } }
+{ $description "Brings a specialized array for holding values of " { $snippet "type" } " into the vocabulary search path. The generated words are documented in " { $link "specialized-array-words" } "." } ;
+
+ARTICLE: "specialized-array-words" "Specialized array words"
+"The " { $link POSTPONE: SPECIALIZED-ARRAY: } " parsing word generates the specialized array type if it hasn't been generated already, and adds the following words to the vocabulary search path, where " { $snippet "T" } " is the C type in question:"
{ $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 "<direct-T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } "; stack effect " { $snippet "( alien len -- array )" } } }
+ { { $snippet "(T-array)" } { "Constructor for arrays with elements of type " { $snippet "T" } ", where the initial contents are uninitialized; stack effect " { $snippet "( len -- array )" } } }
+ { { $snippet "malloc-T-array" } { "Constructor for arrays with elements of type " { $snippet "T" } " backed by newly-allocated unmanaged memory; stack effect " { $snippet "( alien len -- array )" } } }
+ { { $snippet "<direct-T-array>" } { "Constructor for arrays with elements of type " { $snippet "T" } " backed by raw memory; 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."
-$nl
-"The primitive C types for which specialized 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 "complex-float" }
- { $snippet "complex-double" }
- { $snippet "void*" }
- { $snippet "bool" }
-}
-"Note that " { $vocab-link "specialized-arrays.bool" } " behaves like a C " { $snippet "bool[]" } " array, and each element takes up 8 bits of space. For a more space-efficient boolean array, see " { $link "bit-arrays" } "."
-$nl
-"Specialized arrays are generated with a functor in the " { $vocab-link "specialized-arrays.functor" } " vocabulary."
+"Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-arrays.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-ARRAY: } ". This ensures that the vocabulary can get generated the first time it is needed." ;
+
+ARTICLE: "specialized-array-c" "Passing specialized arrays to C functions"
+"Each specialized array has a " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. Passing a specialized array as a parameter to a C function call will automatically extract the underlying data. To get at the underlying data directly, call the " { $link >c-ptr } " word on a specialized array." ;
+
+ARTICLE: "specialized-array-math" "Vector arithmetic with specialized arrays"
+"Each specialized array with a numeric type generates specialized versions of the " { $link "math-vectors" } " words. The compiler substitutes calls for these words if it can statically determine input types. The " { $snippet "optimized." } " word in the " { $vocab-link "compiler.tree.debugger" } " vocabulary can be used to determine if this optimization is being performed for a particular piece of code." ;
+
+ARTICLE: "specialized-array-examples" "Specialized array examples"
+"Let's import specialized float arrays:"
+{ $code "USING: specialized-arrays math.constants math.functions ;" "SPECIALIZED-ARRAY: float" }
+"Creating a float array with 3 elements:"
+{ $code "1.0 [ sin ] [ cos ] [ tan ] tri float-array{ } 3sequence ." }
+"Create a float array and sum the elements:"
+{ $code
+ "1000 iota [ 1000 /f pi * sin ] float-array{ } map-as"
+ "0.0 [ + ] reduce ."
+} ;
+
+ARTICLE: "specialized-arrays" "Specialized arrays"
+"The " { $vocab-link "specialized-arrays" } " vocabulary implements fixed-length sequence types for storing machine values in a space-efficient manner without boxing."
$nl
-"The " { $vocab-link "specialized-vectors" } " vocabulary provides resizable versions of the above." ;
+"A specialized array type needs to be generated for each element type. This is done with a parsing word:"
+{ $subsection POSTPONE: SPECIALIZED-ARRAY: }
+"This parsing word adds new words to the search path:"
+{ $subsection "specialized-array-words" }
+{ $subsection "specialized-array-c" }
+{ $subsection "specialized-array-math" }
+{ $subsection "specialized-array-examples" }
+"The " { $vocab-link "specialized-vectors" } " vocabulary provides a resizable version of this abstraction." ;
ABOUT: "specialized-arrays"
IN: specialized-arrays.tests
-USING: tools.test alien.syntax specialized-arrays sequences
-specialized-arrays.int specialized-arrays.bool
-specialized-arrays.ushort alien.c-types accessors kernel
-specialized-arrays.char specialized-arrays.uint arrays combinators ;
+USING: tools.test alien.syntax specialized-arrays
+specialized-arrays.private sequences alien.c-types accessors
+kernel arrays combinators compiler compiler.units classes.struct
+combinators.smart compiler.tree.debugger math libc destructors
+sequences.private multiline eval words vocabs namespaces
+assocs prettyprint ;
+
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: bool
+SPECIALIZED-ARRAY: ushort
+SPECIALIZED-ARRAY: char
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: float
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
int-array{ 3 1 3 3 7 } malloc-byte-array 5 <direct-int-array> >array
] 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
\ No newline at end of file
+] unit-test
+
+STRUCT: test-struct
+ { x int }
+ { y int } ;
+
+SPECIALIZED-ARRAY: test-struct
+
+[ 1 ] [
+ 1 test-struct-array{ } new-sequence length
+] unit-test
+
+[ V{ test-struct } ] [
+ [ [ test-struct-array <struct> ] test-struct-array{ } output>sequence first ] final-classes
+] unit-test
+
+: make-point ( x y -- struct )
+ test-struct <struct-boa> ;
+
+[ 5/4 ] [
+ 2 <test-struct-array>
+ 1 2 make-point over set-first
+ 3 4 make-point over set-second
+ 0 [ [ x>> ] [ y>> ] bi / + ] reduce
+] unit-test
+
+[ 5/4 ] [
+ [
+ 2 malloc-test-struct-array
+ dup &free drop
+ 1 2 make-point over set-first
+ 3 4 make-point over set-second
+ 0 [ [ x>> ] [ y>> ] bi / + ] reduce
+ ] with-destructors
+] unit-test
+
+[ ] [ ALIEN: 123 10 <direct-test-struct-array> drop ] unit-test
+
+[ ] [
+ [
+ 10 malloc-test-struct-array
+ &free drop
+ ] with-destructors
+] unit-test
+
+[ 15 ] [ 15 10 <test-struct-array> resize length ] unit-test
+
+[ S{ test-struct f 12 20 } ] [
+ test-struct-array{
+ S{ test-struct f 4 20 }
+ S{ test-struct f 12 20 }
+ S{ test-struct f 20 20 }
+ } second
+] unit-test
+
+! Regression
+STRUCT: fixed-string { text char[100] } ;
+
+SPECIALIZED-ARRAY: fixed-string
+
+[ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [
+ ALIEN: 123 4 <direct-fixed-string-array> [ (underlying)>> ] { } map-as
+] unit-test
+
+! Ensure that byte-length works with direct arrays
+[ 400 ] [
+ ALIEN: 123 100 <direct-int-array> byte-length
+] unit-test
+
+! Test prettyprinting
+[ "int-array{ 1 2 3 }" ] [ int-array{ 1 2 3 } unparse ] unit-test
+[ "int-array@ f 100" ] [ f 100 <direct-int-array> unparse ] unit-test
+
+! If the C type doesn't exist, don't generate a vocab
+[ ] [
+ [ "__does_not_exist__" specialized-array-vocab forget-vocab ] with-compilation-unit
+ "__does_not_exist__" c-types get delete-at
+] unit-test
+
+[
+ <"
+IN: specialized-arrays.tests
+USING: specialized-arrays ;
+
+SPECIALIZED-ARRAY: __does_not_exist__ "> eval( -- )
+] must-fail
+
+[ ] [
+ <"
+IN: specialized-arrays.tests
+USING: classes.struct specialized-arrays ;
+
+STRUCT: __does_not_exist__ { x int } ;
+
+SPECIALIZED-ARRAY: __does_not_exist__
+"> eval( -- )
+] unit-test
+
+[ f ] [
+ "__does_not_exist__-array{"
+ "__does_not_exist__" specialized-array-vocab lookup
+ deferred?
+] unit-test
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences vocabs vocabs.loader ;
+USING: accessors alien alien.c-types assocs byte-arrays classes
+compiler.units functors kernel lexer libc math
+math.vectors.specialization namespaces parser prettyprint.custom
+sequences sequences.private strings summary vocabs vocabs.loader
+vocabs.parser words fry combinators ;
IN: specialized-arrays
MIXIN: specialized-array
+
INSTANCE: specialized-array sequence
GENERIC: direct-array-syntax ( obj -- word )
+ERROR: bad-byte-array-length byte-array type ;
+
+M: bad-byte-array-length summary
+ drop "Byte array length doesn't divide type width" ;
+
+: (underlying) ( n c-type -- array )
+ heap-size * (byte-array) ; inline
+
+: <underlying> ( n type -- array )
+ heap-size * <byte-array> ; inline
+
+<PRIVATE
+
+FUNCTOR: define-array ( T -- )
+
+A DEFINES-CLASS ${T}-array
+S DEFINES-CLASS ${T}-sequence
+<A> DEFINES <${A}>
+(A) DEFINES (${A})
+<direct-A> DEFINES <direct-${A}>
+malloc-A DEFINES malloc-${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 ]
+
+WHERE
+
+MIXIN: S
+
+TUPLE: A
+{ underlying c-ptr read-only }
+{ length array-capacity read-only } ;
+
+: <direct-A> ( alien len -- specialized-array ) A boa ; inline
+
+: <A> ( n -- specialized-array ) [ T <underlying> ] keep <direct-A> ; inline
+
+: (A) ( n -- specialized-array ) [ T (underlying) ] keep <direct-A> ; inline
+
+: malloc-A ( len -- specialized-array ) [ T heap-size calloc ] 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
+ <direct-A> ; inline
+
+M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline
+
+M: A length length>> ; inline
+
+M: A nth-unsafe underlying>> NTH call ; inline
+
+M: A set-nth-unsafe underlying>> SET-NTH call ; inline
+
+: >A ( seq -- specialized-array ) A new clone-like ;
+
+M: A like drop dup A instance? [ >A ] unless ; inline
+
+M: A new-sequence drop (A) ; inline
+
+M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
+
+M: A resize
+ [
+ [ T heap-size * ] [ underlying>> ] bi*
+ resize-byte-array
+ ] [ drop ] 2bi
+ <direct-A> ; inline
+
+M: A byte-length length T heap-size * ; inline
+
+M: A direct-array-syntax drop \ A@ ;
+
+M: A pprint-delims drop \ A{ \ } ;
+
+M: A >pprint-sequence ;
+
+SYNTAX: A{ \ } [ >A ] parse-literal ;
+SYNTAX: A@ scan-object scan-object <direct-A> parsed ;
+
+INSTANCE: A specialized-array
+
+A T c-type-boxed-class f specialize-vector-words
+
+;FUNCTOR
+
+: underlying-type ( c-type -- c-type' )
+ dup c-types get at {
+ { [ dup not ] [ drop no-c-type ] }
+ { [ dup string? ] [ nip underlying-type ] }
+ [ drop ]
+ } cond ;
+
+: specialized-array-vocab ( c-type -- vocab )
+ "specialized-arrays.instances." prepend ;
+
+PRIVATE>
+
+: generate-vocab ( vocab-name quot -- vocab )
+ [ dup vocab [ ] ] dip '[
+ [
+ [
+ _ with-current-vocab
+ ] with-compilation-unit
+ ] keep
+ ] ?if ; inline
+
+: define-array-vocab ( type -- vocab )
+ underlying-type
+ [ specialized-array-vocab ] [ '[ _ define-array ] ] bi
+ generate-vocab ;
+
+M: string require-c-array define-array-vocab drop ;
+
+ERROR: specialized-array-vocab-not-loaded c-type ;
+
+M: string c-array-constructor
+ underlying-type
+ dup [ "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup
+ [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
+
+M: string c-(array)-constructor
+ underlying-type
+ dup [ "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup
+ [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
+
+M: string c-direct-array-constructor
+ underlying-type
+ dup [ "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup
+ [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
+
+SYNTAX: SPECIALIZED-ARRAY:
+ scan define-array-vocab use-vocab ;
+
"prettyprint" vocab [
"specialized-arrays.prettyprint" require
] when
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.uchar
-
-<< "uchar" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.uint
-
-<< "uint" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.ulong
-
-<< "ulong" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.ulonglong
-
-<< "ulonglong" define-array >>
\ No newline at end of file
+++ /dev/null
-USE: specialized-arrays.functor
-IN: specialized-arrays.ushort
-
-<< "ushort" define-array >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.alien ;
-IN: specialized-vectors.alien
-
-<< "void*" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.bool ;
-IN: specialized-vectors.bool
-
-<< "bool" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.char ;
-IN: specialized-vectors.char
-
-<< "char" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.double ;
-IN: specialized-vectors.double
-
-<< "double" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.float ;
-IN: specialized-vectors.float
-
-<< "float" define-vector >>
\ 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 alien.c-types functors sequences sequences.private growable
-prettyprint.custom kernel words classes math parser ;
-QUALIFIED: vectors.functor
-IN: specialized-vectors.functor
-
-FUNCTOR: define-vector ( T -- )
-
-V DEFINES-CLASS ${T}-vector
-
-A IS ${T}-array
-S IS ${T}-sequence
-<A> IS <${A}>
-
->V DEFERS >${V}
-V{ DEFINES ${V}{
-
-WHERE
-
-V A <A> vectors.functor:define-vector
-
-M: V contract 2drop ;
-
-M: V byte-length underlying>> byte-length ;
-
-M: V pprint-delims drop \ V{ \ } ;
-
-M: V >pprint-sequence ;
-
-M: V pprint* pprint-object ;
-
-SYNTAX: V{ \ } [ >V ] parse-literal ;
-
-INSTANCE: V growable
-INSTANCE: V S
-
-;FUNCTOR
+++ /dev/null
-Code generation for specialized vectors
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.int ;
-IN: specialized-vectors.int
-
-<< "int" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.long ;
-IN: specialized-vectors.long
-
-<< "long" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.longlong ;
-IN: specialized-vectors.longlong
-
-<< "longlong" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.short ;
-IN: specialized-vectors.short
-
-<< "short" define-vector >>
\ No newline at end of file
-USING: help.markup help.syntax byte-vectors ;
+USING: help.markup help.syntax byte-vectors alien byte-arrays ;
IN: specialized-vectors
-ARTICLE: "specialized-vectors" "Specialized vectors"
-"The " { $vocab-link "specialized-vectors" } " vocabulary implements resizable sequence types for storing machine values in a space-efficient manner without boxing."
-$nl
-"For each primitive C type " { $snippet "T" } ", a set of words are defined:"
+HELP: SPECIALIZED-VECTOR:
+{ $syntax "SPECIALIZED-VECTOR: type" }
+{ $values { "type" "a C type" } }
+{ $description "Brings a specialized vector for holding values of " { $snippet "type" } " into the vocabulary search path. The generated words are documented in " { $link "specialized-vector-words" } "." } ;
+
+ARTICLE: "specialized-vector-words" "Specialized vector words"
+"The " { $link POSTPONE: SPECIALIZED-VECTOR: } " parsing word generates the specialized vector type if it hasn't been generated already, and adds the following words to the vocabulary search path, where " { $snippet "T" } " is the C type in question:"
{ $table
{ { $snippet "T-vector" } { "The class of vectors with elements of type " { $snippet "T" } } }
{ { $snippet "<T-vector>" } { "Constructor for vectors with elements of type " { $snippet "T" } "; stack effect " { $snippet "( len -- vector )" } } }
{ { $snippet ">T-vector" } { "Converts a sequence into a specialized vector of type " { $snippet "T" } "; stack effect " { $snippet "( seq -- vector )" } } }
{ { $snippet "T-vector{" } { "Literal syntax, consists of a series of values terminated by " { $snippet "}" } } }
}
-"The primitive C types for which specialized vectors 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" }
-}
-"Specialized vectors are generated with a functor in the " { $vocab-link "specialized-vectors.functor" } " vocabulary."
-$nl
-"The " { $vocab-link "specialized-arrays" } " vocabulary provides fixed-length versions of the above." ;
+"Behind the scenes, these words are placed in a vocabulary named " { $snippet "specialized-vectors.instances.T" } ", however this vocabulary should not be placed in a " { $link POSTPONE: USING: } " form directly. Instead, always use " { $link POSTPONE: SPECIALIZED-VECTOR: } ". This ensures that the vocabulary can get generated the first time it is needed." ;
+
+ARTICLE: "specialized-vector-c" "Passing specialized arrays to C functions"
+"Each specialized array has a " { $slot "underlying" } " slot holding a specialized array, which in turn has an " { $slot "underlying" } " slot holding a " { $link byte-array } " with the raw data. Passing a specialized vector as a parameter to a C function call will automatically extract the underlying data. To get at the underlying data directly, call the " { $link >c-ptr } " word on a specialized vector." ;
+
+ARTICLE: "specialized-vectors" "Specialized vectors"
+"The " { $vocab-link "specialized-vectors" } " vocabulary implements resizable sequence types for storing machine values in a space-efficient manner without boxing."
+{ $subsection "specialized-vector-words" }
+{ $subsection "specialized-vector-c" }
+"The " { $vocab-link "specialized-arrays" } " vocabulary provides a fixed-length version of this abstraction." ;
ABOUT: "specialized-vectors"
IN: specialized-vectors.tests
-USING: specialized-arrays.float
-specialized-vectors.float
-specialized-vectors.double
+USING: specialized-arrays specialized-vectors
tools.test kernel sequences ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-VECTOR: float
+SPECIALIZED-VECTOR: double
[ 3 ] [ double-vector{ 1 2 } 3 over push length ] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types assocs compiler.units functors
+growable kernel lexer namespaces parser prettyprint.custom
+sequences specialized-arrays specialized-arrays.private strings
+vocabs vocabs.parser fry ;
+QUALIFIED: vectors.functor
IN: specialized-vectors
+
+<PRIVATE
+
+FUNCTOR: define-vector ( T -- )
+
+V DEFINES-CLASS ${T}-vector
+
+A IS ${T}-array
+S IS ${T}-sequence
+<A> IS <${A}>
+
+>V DEFERS >${V}
+V{ DEFINES ${V}{
+
+WHERE
+
+V A <A> vectors.functor:define-vector
+
+M: V contract 2drop ;
+
+M: V byte-length underlying>> byte-length ;
+
+M: V pprint-delims drop \ V{ \ } ;
+
+M: V >pprint-sequence ;
+
+M: V pprint* pprint-object ;
+
+SYNTAX: V{ \ } [ >V ] parse-literal ;
+
+INSTANCE: V growable
+INSTANCE: V S
+
+;FUNCTOR
+
+: specialized-vector-vocab ( type -- vocab )
+ "specialized-vectors.instances." prepend ;
+
+PRIVATE>
+
+: define-vector-vocab ( type -- vocab )
+ underlying-type
+ [ specialized-vector-vocab ] [ '[ _ define-vector ] ] bi
+ generate-vocab ;
+
+SYNTAX: SPECIALIZED-VECTOR:
+ scan
+ [ define-array-vocab use-vocab ]
+ [ define-vector-vocab use-vocab ] bi ;
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.uchar ;
-IN: specialized-vectors.uchar
-
-<< "uchar" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.uint ;
-IN: specialized-vectors.uint
-
-<< "uint" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.ulong ;
-IN: specialized-vectors.ulong
-
-<< "ulong" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.ulonglong ;
-IN: specialized-vectors.ulonglong
-
-<< "ulonglong" define-vector >>
\ No newline at end of file
+++ /dev/null
-USING: specialized-vectors.functor specialized-arrays.ushort ;
-IN: specialized-vectors.ushort
-
-<< "ushort" define-vector >>
\ No newline at end of file
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: accessors arrays kernel prettyprint.backend
-prettyprint.custom prettyprint.sections sequences struct-arrays ;
-IN: struct-arrays.prettyprint
-
-M: struct-array pprint-delims
- drop \ struct-array{ \ } ;
-
-M: struct-array >pprint-sequence
- [ >array ] [ class>> ] bi prefix ;
-
-: pprint-struct-array-pointer ( struct-array -- )
- \ struct-array@
- [ [ class>> pprint-word ] [ underlying>> pprint* ] [ length>> pprint* ] tri ]
- pprint-prefix ;
-
-M: struct-array pprint*
- [ pprint-object ]
- [ pprint-struct-array-pointer ] pprint-c-object ;
-
+++ /dev/null
-IN: struct-arrays
-USING: classes.struct help.markup help.syntax alien strings math multiline ;
-
-HELP: struct-array
-{ $class-description "The class of C struct and union arrays."
-$nl
-"The " { $slot "underlying" } " slot holds a " { $link c-ptr } " with the raw data. This pointer can be passed to C functions." } ;
-
-HELP: <struct-array>
-{ $values { "length" integer } { "struct-class" struct-class } { "struct-array" struct-array } }
-{ $description "Creates a new array for holding values of the specified struct type." } ;
-
-HELP: <direct-struct-array>
-{ $values { "alien" c-ptr } { "length" integer } { "struct-class" struct-class } { "struct-array" struct-array } }
-{ $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ;
-
-HELP: struct-array-on
-{ $values { "struct" struct } { "length" integer } { "struct-array" struct-array } }
-{ $description "Create a new array for holding values of " { $snippet "struct" } "'s C type, backed by the memory starting at " { $snippet "struct" } "'s address." }
-{ $examples
-"This word is useful with the FFI. When a C function has a pointer to a struct as its return type (or a C callback has a struct pointer as an argument type), Factor automatically wraps the pointer in a " { $link struct } " object. If the pointer actually references an array of objects, this word will convert the struct object to a struct array object:"
-{ $code <" USING: alien.syntax classes.struct struct-arrays ;
-IN: scratchpad
-
-STRUCT: zim { zang int } { zung int } ;
-
-FUNCTION: zim* zingle ( ) ; ! Returns a pointer to 20 zims
-
-zingle 20 struct-array-on "> }
-} ;
-
-HELP: struct-array{
-{ $syntax "struct-array{ class value value value ... }" }
-{ $description "Literal syntax for a " { $link struct-array } " containing structs of the given " { $link struct } " class." } ;
-
-HELP: struct-array@
-{ $syntax "struct-array@ class alien length" }
-{ $description "Literal syntax for a " { $link struct-array } " at a particular memory address. The prettyprinter uses this syntax when the memory backing a struct array object is invalid. This syntax should not generally be used in source code." } ;
-
-{ POSTPONE: struct-array{ POSTPONE: struct-array@ } related-words
-
-ARTICLE: "struct-arrays" "C struct and union arrays"
-"The " { $vocab-link "struct-arrays" } " vocabulary implements arrays specialized for holding C struct and union values."
-{ $subsection struct-array }
-{ $subsection <struct-array> }
-{ $subsection <direct-struct-array> }
-{ $subsection struct-array-on }
-"Struct arrays have literal syntax:"
-{ $subsection POSTPONE: struct-array{ } ;
-
-ABOUT: "struct-arrays"
+++ /dev/null
-IN: struct-arrays.tests
-USING: classes.struct struct-arrays tools.test kernel math sequences
-alien.syntax alien.c-types destructors libc accessors sequences.private
-compiler.tree.debugger ;
-
-STRUCT: test-struct-array
- { x int }
- { y int } ;
-
-: make-point ( x y -- struct )
- test-struct-array <struct-boa> ;
-
-[ 5/4 ] [
- 2 test-struct-array <struct-array>
- 1 2 make-point over set-first
- 3 4 make-point over set-second
- 0 [ [ x>> ] [ y>> ] bi / + ] reduce
-] unit-test
-
-[ 5/4 ] [
- [
- 2 test-struct-array malloc-struct-array
- dup &free drop
- 1 2 make-point over set-first
- 3 4 make-point over set-second
- 0 [ [ x>> ] [ y>> ] bi / + ] reduce
- ] with-destructors
-] unit-test
-
-[ ] [ ALIEN: 123 10 test-struct-array <direct-struct-array> drop ] unit-test
-
-[ ] [
- [
- 10 test-struct-array malloc-struct-array
- &free drop
- ] with-destructors
-] unit-test
-
-[ 15 ] [ 15 10 test-struct-array <struct-array> resize length ] unit-test
-
-[ S{ test-struct-array f 12 20 } ] [
- struct-array{ test-struct-array
- S{ test-struct-array f 4 20 }
- S{ test-struct-array f 12 20 }
- S{ test-struct-array f 20 20 }
- } second
-] unit-test
-
-! Regression
-STRUCT: fixed-string { text char[100] } ;
-
-[ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [
- ALIEN: 123 4 fixed-string <direct-struct-array> [ (underlying)>> ] { } map-as
-] unit-test
-
-[ 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
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types alien.structs byte-arrays
-classes classes.struct kernel libc math parser sequences
-sequences.private words fry memoize compiler.units ;
-IN: struct-arrays
-
-TUPLE: struct-array
-{ underlying c-ptr read-only }
-{ length array-capacity read-only }
-{ element-size array-capacity read-only }
-{ class read-only }
-{ ctor read-only } ;
-
-<PRIVATE
-
-: (nth-ptr) ( i struct-array -- alien )
- [ element-size>> * >fixnum ] [ underlying>> ] bi <displaced-alien> ; inline
-
-: (struct-element-constructor) ( struct-class -- word )
- [
- "struct-array-ctor" f <word>
- [ swap '[ _ memory>struct ] (( alien -- object )) define-inline ] keep
- ] with-compilation-unit ;
-
-! Foldable memo word. This is an optimization; by precompiling a
-! constructor for array elements, we avoid memory>struct's slow path.
-MEMO: struct-element-constructor ( struct-class -- word )
- (struct-element-constructor) ; foldable
-
-PRIVATE>
-
-M: struct-array length length>> ; inline
-
-M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
-
-M: struct-array nth-unsafe
- [ (nth-ptr) ] [ ctor>> ] bi execute( alien -- object ) ; inline
-
-M: struct-array set-nth-unsafe
- [ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline
-
-ERROR: not-a-struct-class struct-class ;
-
-: <direct-struct-array> ( alien length struct-class -- struct-array )
- dup struct-class? [ not-a-struct-class ] unless
- [ heap-size ] [ ] [ struct-element-constructor ]
- tri struct-array boa ; inline
-
-M: struct-array new-sequence
- [ element-size>> * (byte-array) ] [ length>> ] [ class>> ] tri
- <direct-struct-array> ; inline
-
-M: struct-array resize ( n seq -- newseq )
- [ [ element-size>> * ] [ underlying>> ] bi resize ] [ class>> ] 2bi
- <direct-struct-array> ; inline
-
-: <struct-array> ( length struct-class -- struct-array )
- [ heap-size * <byte-array> ] 2keep <direct-struct-array> ; inline
-
-ERROR: bad-byte-array-length byte-array ;
-
-: byte-array>struct-array ( byte-array c-type -- struct-array )
- [
- heap-size
- [ dup length ] dip /mod 0 =
- [ drop bad-byte-array-length ] unless
- ] keep <direct-struct-array> ; inline
-
-: struct-array-on ( struct length -- struct-array )
- [ [ >c-ptr ] [ class ] bi ] dip swap <direct-struct-array> ; inline
-
-: malloc-struct-array ( length c-type -- struct-array )
- [ heap-size calloc ] 2keep <direct-struct-array> ; inline
-
-INSTANCE: struct-array sequence
-
-M: struct-type <c-array> ( len c-type -- array )
- dup c-array-constructor
- [ execute( len -- array ) ]
- [ <struct-array> ] ?if ; inline
-
-M: struct-type <c-direct-array> ( alien len c-type -- array )
- dup c-direct-array-constructor
- [ execute( alien len -- array ) ]
- [ <direct-struct-array> ] ?if ; inline
-
-: >struct-array ( sequence class -- struct-array )
- [ dup length ] dip <struct-array>
- [ 0 swap copy ] keep ; inline
-
-SYNTAX: struct-array{
- \ } scan-word [ >struct-array ] curry parse-literal ;
-
-SYNTAX: struct-array@
- scan-word [ scan-object scan-object ] dip <direct-struct-array> parsed ;
-
-USING: vocabs vocabs.loader ;
-
-"prettyprint" vocab [ "struct-arrays.prettyprint" require ] when
+++ /dev/null
-Arrays of C structs and unions
+++ /dev/null
-collections
+++ /dev/null
-IN: struct-vectors
-USING: help.markup help.syntax classes.struct alien strings math ;
-
-HELP: struct-vector
-{ $class-description "The class of growable C struct and union arrays." } ;
-
-HELP: <struct-vector>
-{ $values { "capacity" integer } { "struct-class" struct-class } { "struct-vector" struct-vector } }
-{ $description "Creates a new vector with the given initial capacity." } ;
-
-ARTICLE: "struct-vectors" "C struct and union vectors"
-"The " { $vocab-link "struct-vectors" } " vocabulary implements vectors specialized for holding C struct and union values. These are growable versions of " { $vocab-link "struct-arrays" } "."
-{ $subsection struct-vector }
-{ $subsection <struct-vector> } ;
-
-ABOUT: "struct-vectors"
+++ /dev/null
-IN: struct-vectors.tests
-USING: struct-vectors tools.test alien.c-types classes.struct accessors
-namespaces kernel sequences ;
-
-STRUCT: point { x float } { y float } ;
-
-: make-point ( x y -- point ) point <struct-boa> ;
-
-[ ] [ 1 point <struct-vector> "v" set ] unit-test
-
-[ 1.5 6.0 ] [
- 1.0 2.0 make-point "v" get push
- 3.0 4.5 make-point "v" get push
- 1.5 6.0 make-point "v" get push
- "v" get pop [ x>> ] [ y>> ] bi
-] unit-test
\ 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 growable kernel math sequences
-sequences.private struct-arrays ;
-IN: struct-vectors
-
-TUPLE: struct-vector
-{ underlying struct-array }
-{ length array-capacity }
-{ c-type read-only } ;
-
-: <struct-vector> ( capacity struct-class -- struct-vector )
- [ <struct-array> 0 ] keep struct-vector boa ; inline
-
-M: struct-vector byte-length underlying>> byte-length ;
-
-M: struct-vector new-sequence
- [ c-type>> <struct-array> ] [ [ >fixnum ] [ c-type>> ] bi* ] 2bi
- struct-vector boa ;
-
-M: struct-vector contract 2drop ;
-
-M: struct-array new-resizable c-type>> <struct-vector> ;
-
-INSTANCE: struct-vector growable
{ $subsection add-timing }
{ $subsection word-timing. }
"All of the above words are implemented using a single combinator which applies a quotation to a word definition to yield a new definition:"
-{ $subsection annotate } ;
+{ $subsection annotate }
+{ $warning
+ "Certain internal words, such as words in the " { $vocab-link "math" } ", " { $vocab-link "sequences" } " and UI vocabularies, cannot be annotated, since the annotated code may end up recursively invoking the word in question. This may crash or hang Factor. It is safest to only define annotations on your own words."
+} ;
ABOUT: "tools.annotations"
"vocab:tools/deploy/shaker/strip-destructors.factor"
run-file ;
-: strip-struct-arrays ( -- )
- "struct-arrays" vocab [
- "Stripping dynamic struct array code" show
- "vocab:tools/deploy/shaker/strip-struct-arrays.factor"
- run-file
- ] when ;
-
: strip-call ( -- )
"Stripping stack effect checking from call( and execute(" show
"vocab:tools/deploy/shaker/strip-call.factor" run-file ;
"slots"
"special"
"specializer"
+ "specializations"
"struct-slots"
! UI needs this
! "superclass"
{ } { "math.partial-dispatch" } strip-vocab-globals %
- { } { "math.vectors.specialization" } strip-vocab-globals %
-
{ } { "peg" } strip-vocab-globals %
] when
: strip ( -- )
init-stripper
strip-libc
- strip-struct-arrays
strip-destructors
strip-call
strip-cocoa
+++ /dev/null
-USING: kernel stack-checker.transforms ;
-IN: struct-arrays.private
-
-: struct-element-constructor ( c-type -- word )
- "Struct array usages must be compiled" throw ;
-
-<<
-
-\ struct-element-constructor [
- (struct-element-constructor) [ ] curry
-] 1 define-transform
-
->>
\ No newline at end of file
SYMBOL: file
: file-failure ( error -- )
- f file get f failure ;
+ [ f file get ] keep error-line failure ;
:: (unit-test) ( output input -- error ? )
[ { } input with-datastack output assert-sequence= f f ] [ t ] recover ;
! Copyright (C) 2005, 2006 Doug Coleman.
! Portions copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings arrays assocs ui ui.private
-ui.gadgets ui.gadgets.private ui.backend ui.clipboards
-ui.gadgets.worlds ui.gestures ui.event-loop io kernel math
-math.vectors namespaces make sequences strings vectors words
-windows.kernel32 windows.gdi32 windows.user32 windows.opengl32
-windows.messages windows.types windows.offscreen windows.nt
-threads libc combinators fry combinators.short-circuit continuations
-command-line shuffle opengl ui.render math.bitwise locals
-accessors math.rectangles math.order calendar ascii sets
-io.encodings.utf16n windows.errors literals ui.pixel-formats
-ui.pixel-formats.private memoize classes struct-arrays classes.struct ;
+USING: alien alien.c-types alien.strings arrays assocs ui
+ui.private ui.gadgets ui.gadgets.private ui.backend
+ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io
+kernel math math.vectors namespaces make sequences strings
+vectors words windows.kernel32 windows.gdi32 windows.user32
+windows.opengl32 windows.messages windows.types
+windows.offscreen windows.nt threads libc combinators fry
+combinators.short-circuit continuations command-line shuffle
+opengl ui.render math.bitwise locals accessors math.rectangles
+math.order calendar ascii sets io.encodings.utf16n
+windows.errors literals ui.pixel-formats
+ui.pixel-formats.private memoize classes
+specialized-arrays classes.struct ;
+SPECIALIZED-ARRAY: POINT
IN: ui.backend.windows
SINGLETON: windows-ui-backend
: client-area>RECT ( hwnd -- RECT )
RECT <struct>
[ GetClientRect win32-error=0/f ]
- [ >c-ptr "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ]
+ [ >c-ptr byte-array>POINT-array [ ClientToScreen drop ] with each ]
[ nip ] 2tri ;
: hwnd>RECT ( hwnd -- RECT )
$nl
"A button's appearance can vary depending on the state of the mouse button if the " { $snippet "interior" } " or " { $snippet "boundary" } " slots are set to instances of " { $link button-pen } "."
$nl
-"A button can be selected, which is distinct from being pressed. This state is held in the " { $snippet "selected?" } " slot, and is used by " { $link checkbox } " instances to render themselves when they're checked." } ;
+"A button can be selected, which is distinct from being pressed. This state is held in the " { $snippet "selected?" } " slot, and is used by " { $link checkbox } " instances to render themselves when they're checked."
+$nl
+"A button can optionally display a message in the window's status bar whenever the mouse cursor hovers over the button. To enable this behavior, just set a string to the button's " { $snippet "tooltip" } " slot." } ;
HELP: <button>
{ $values { "label" gadget } { "quot" { $quotation "( button -- )" } } { "button" "a new " { $link button } } }
FROM: models => change-model ;
IN: ui.gadgets.buttons
-TUPLE: button < border pressed? selected? quot ;
+TUPLE: button < border pressed? selected? quot tooltip ;
<PRIVATE
>>pressed?
relayout-1 ;
+: button-enter ( button -- )
+ dup dup tooltip>> [ swap show-status ] [ drop ] if* button-update ;
+
+: button-leave ( button -- )
+ dup "" swap show-status button-update ;
+
: button-clicked ( button -- )
dup button-update
dup button-rollover?
button H{
{ T{ button-up } [ button-clicked ] }
{ T{ button-down } [ button-update ] }
- { mouse-leave [ button-update ] }
- { mouse-enter [ button-update ] }
+ { mouse-leave [ button-leave ] }
+ { mouse-enter [ button-enter ] }
} set-gestures
: new-button ( label quot class -- button )
[ append theme-image ] tri-curry@ tri
] 2dip <tile-pen> ;
-CONSTANT: button-background
- T{ rgba
- f
- 0.8901960784313725
- 0.8862745098039215
- 0.8588235294117647
- 1.0
- }
-
-CONSTANT: button-clicked-background
- T{ rgba
- f
- 0.2156862745098039
- 0.2431372549019608
- 0.2823529411764706
- 1.0
- }
-
+CONSTANT: button-background COLOR: FactorLightTan
+CONSTANT: button-clicked-background COLOR: FactorDarkSlateBlue
+
: <border-button-pen> ( -- pen )
- "button" button-background COLOR: black <border-button-state-pen> dup
- "button-clicked" button-clicked-background COLOR: white <border-button-state-pen> dup dup
+ "button" button-background button-clicked-background
+ <border-button-state-pen> dup
+ "button-clicked" button-clicked-background COLOR: white
+ <border-button-state-pen> dup dup
<button-pen> ;
+: border-button-label-theme ( gadget -- )
+ dup label? [ [ clone t >>bold? ] change-font ] when drop ;
+
: border-button-theme ( gadget -- gadget )
+ dup children>> first border-button-label-theme
horizontal >>orientation
<border-button-pen> >>interior
dup dup interior>> pen-pref-dim >>min-dim
: command-button-quot ( target command -- quot )
'[ _ _ invoke-command ] ;
+: gesture>tooltip ( gesture -- str/f )
+ dup [ gesture>string "Shortcut: " prepend ] when ;
+
: <command-button> ( target gesture command -- button )
- [ command-string swap ] keep command-button-quot
- '[ drop @ ] <border-button> ;
+ swapd [ command-name swap ] keep command-button-quot
+ '[ drop @ ] <border-button> swap gesture>tooltip >>tooltip ;
: <toolbar> ( target -- toolbar )
<shelf>
namespaces make opengl sequences strings splitting ui.gadgets
ui.gadgets.tracks ui.gadgets.packs fonts ui.render ui.pens.solid
ui.baseline-alignment ui.text colors colors.constants models
-combinators ;
+combinators opengl.gl ;
IN: ui.gadgets.labels
! A label gadget draws a string.
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors models models.delay models.arrow
-sequences ui.gadgets.labels ui.gadgets.tracks
-ui.gadgets.worlds ui.gadgets ui ui.private kernel calendar summary ;
+USING: accessors calendar colors colors.constants fonts kernel
+models models.arrow models.delay sequences summary ui
+ui.gadgets ui.gadgets.labels ui.gadgets.tracks
+ui.gadgets.worlds ui.pens.solid ui.private ;
IN: ui.gadgets.status-bar
+: status-bar-font ( -- font )
+ sans-serif-font clone
+ COLOR: FactorDarkSlateBlue >>background
+ COLOR: white >>foreground ;
+
+: status-bar-theme ( label -- label )
+ status-bar-font >>font
+ COLOR: FactorDarkSlateBlue <solid> >>interior ;
+
: <status-bar> ( model -- gadget )
1/10 seconds <delay> [ "" like ] <arrow> <label-control>
- reverse-video-theme
+ status-bar-theme
t >>root? ;
: open-status-window ( gadget title/attributes -- )
HELP: set-title
{ $values { "string" string } { "world" world } }
-{ $description "Sets the title bar of the native window containing the world." }
-{ $notes "This word should not be called directly by user code. Instead, change the " { $snippet "title" } " slot model; see " { $link "models" } "." } ;
+{ $description "Sets the title bar of the native window containing the world." } ;
HELP: set-gl-context
{ $values { "world" world } }
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors math math.vectors locals sequences
-specialized-arrays.float colors arrays combinators
+specialized-arrays colors arrays combinators
opengl opengl.gl ui.pens ui.pens.caching ;
+SPECIALIZED-ARRAY: float
IN: ui.pens.gradient
! Gradient pen
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors colors help.markup help.syntax kernel opengl
-opengl.gl sequences specialized-arrays.float math.vectors
-ui.gadgets ui.pens ;
+opengl.gl sequences math.vectors ui.gadgets ui.pens
+specialized-arrays ;
+SPECIALIZED-ARRAY: float
IN: ui.pens.polygon
! Polygon pen
USING: accessors assocs classes destructors functors kernel
-lexer math parser sequences specialized-arrays.int ui.backend
+lexer math parser sequences specialized-arrays ui.backend
words ;
+SPECIALIZED-ARRAY: int
IN: ui.pixel-formats
SYMBOLS:
ui.tools.browser.history ;
IN: ui.tools.browser
-TUPLE: browser-gadget < tool history pane scroller search-field popup ;
+TUPLE: browser-gadget < tool history scroller search-field popup ;
{ 650 400 } browser-gadget set-tool-dim
dup <history> >>history
dup <search-field> >>search-field
dup <browser-toolbar> { 3 3 } <border> { 1 0 } >>fill f track-add
- dup <help-pane> >>pane
- dup pane>> <scroller> >>scroller
- dup scroller>> 1 track-add ;
+ dup dup <help-pane> { 10 0 } <border> { 1 1 } >>fill
+ <scroller> >>scroller scroller>> 1 track-add ;
M: browser-gadget graft*
[ add-definition-observer ] [ call-next-method ] bi ;
} 2|| ;
M: browser-gadget definitions-changed ( assoc browser -- )
- model>> [ value>> swap showing-definition? ] keep
- '[ _ notify-connections ] when ;
+ [ model>> value>> swap showing-definition? ] keep
+ '[ _ [ history-value ] keep set-history-value ] when ;
M: browser-gadget focusable-child* search-field>> ;
M: error-renderer column-alignment drop { 0 1 0 0 } ;
: sort-errors ( seq -- seq' )
- [ [ [ line#>> ] [ asset>> unparse-short ] bi 2array ] keep ] { } map>assoc
+ [ [ [ line#>> 0 or ] [ asset>> unparse-short ] bi 2array ] keep ] { } map>assoc
sort-keys values ;
: file-matches? ( error pathname/f -- ? )
! Copyright (C) 2008 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: alien.syntax math math.bitwise ;\r
+USING: alien.syntax math math.bitwise classes.struct ;\r
IN: unix.linux.inotify\r
\r
-C-STRUCT: inotify-event\r
- { "int" "wd" } ! watch descriptor\r
- { "uint" "mask" } ! watch mask\r
- { "uint" "cookie" } ! cookie to synchronize two events\r
- { "uint" "len" } ! length (including nulls) of name\r
- { "char[0]" "name" } ! stub for possible name\r
- ;\r
+STRUCT: inotify-event\r
+ { wd int }\r
+ { mask uint }\r
+ { cookie uint }\r
+ { len uint }\r
+ { name char[0] } ;\r
\r
CONSTANT: IN_ACCESS HEX: 1 ! File was accessed\r
CONSTANT: IN_MODIFY HEX: 2 ! File was modified\r
CONSTANT: IN_Q_OVERFLOW HEX: 4000 ! Event queued overflowed\r
CONSTANT: IN_IGNORED HEX: 8000 ! File was ignored\r
\r
-: IN_CLOSE ( -- n ) IN_CLOSE_WRITE IN_CLOSE_NOWRITE bitor ; inline ! close\r
-: IN_MOVE ( -- n ) IN_MOVED_FROM IN_MOVED_TO bitor ; inline ! moves\r
+: IN_CLOSE ( -- n ) { IN_CLOSE_WRITE IN_CLOSE_NOWRITE } flags ; foldable ! close\r
+: IN_MOVE ( -- n ) { IN_MOVED_FROM IN_MOVED_TO } flags ; foldable ! moves\r
\r
CONSTANT: IN_ONLYDIR HEX: 1000000 ! only watch the path if it is a directory\r
CONSTANT: IN_DONT_FOLLOW HEX: 2000000 ! don't follow a sym link\r
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings
-combinators.short-circuit fry kernel layouts sequences
-specialized-arrays.alien accessors ;
+combinators.short-circuit fry kernel layouts sequences accessors
+specialized-arrays ;
IN: unix.utilities
+SPECIALIZED-ARRAY: void*
+
: more? ( alien -- ? )
{ [ ] [ *void* ] } 1&& ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sorting sequences vocabs io io.styles arrays assocs
-namespaces sets parser colors prettyprint.backend prettyprint.sections
-vocabs.parser make fry math.order ;
+USING: accessors arrays assocs colors colors.constants fry io
+io.styles kernel make math.order namespaces parser
+prettyprint.backend prettyprint.sections prettyprint.stylesheet
+sequences sets sorting vocabs vocabs.parser ;
IN: vocabs.prettyprint
: pprint-vocab ( vocab -- )
- [ vocab-name ] [ vocab ] bi present-text ;
+ [ vocab-name ] [ vocab vocab-style ] bi styled-text ;
: pprint-in ( vocab -- )
[ \ IN: pprint-word pprint-vocab ] with-pprint ;
"To avoid doing this in the future, add the following forms" print
"at the top of the source file:" print nl
] with-style
- { { page-color T{ rgba f 0.8 0.8 0.8 1.0 } } }
+ { { page-color COLOR: FactorLightTan } }
[ manifest get pprint-manifest ] with-nesting
nl nl
] print-use-hook set-global
\ No newline at end of file
namespaces windows.ole32 libc vocabs assocs accessors arrays
sequences quotations combinators math words compiler.units
destructors fry math.parser generalizations sets
-specialized-arrays.alien windows.kernel32 classes.struct ;
+specialized-arrays windows.kernel32 classes.struct ;
+SPECIALIZED-ARRAY: void*
IN: windows.com.wrapper
TUPLE: com-wrapper < disposable callbacks vtbls ;
windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces
combinators sequences fry math accessors macros words quotations
libc continuations generalizations splitting locals assocs init
-struct-arrays memoize classes.struct ;
+specialized-arrays memoize classes.struct ;
+SPECIALIZED-ARRAY: DIOBJECTDATAFORMAT
IN: windows.dinput.constants
! Some global variables aren't provided by the DirectInput DLL (they're in the
DIOBJECTDATAFORMAT <struct-boa> ;
:: malloc-DIOBJECTDATAFORMAT-array ( struct array -- alien )
- [let | alien [ array length DIOBJECTDATAFORMAT malloc-struct-array ] |
+ [let | alien [ array length malloc-DIOBJECTDATAFORMAT-array ] |
array [| args i |
struct args <DIOBJECTDATAFORMAT>
i alien set-nth
USING: kernel tools.test windows.ole32 alien.c-types
-classes.struct specialized-arrays.uchar windows.kernel32
+classes.struct specialized-arrays windows.kernel32
windows.com.syntax ;
+SPECIALIZED-ARRAY: uchar
IN: windows.ole32.tests
[ t ] [
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.uchar
-literals splitting grouping classes.struct combinators.smart ;
+kernel sequences windows.errors windows.types io accessors
+math.order namespaces make math.parser windows.kernel32
+combinators locals specialized-arrays literals splitting
+grouping classes.struct combinators.smart ;
+SPECIALIZED-ARRAY: uchar
IN: windows.ole32
LIBRARY: ole32
classes.struct combinators io.encodings.utf16n io.files
io.pathnames kernel windows.errors windows.com
windows.com.syntax windows.user32 windows.ole32 windows
-specialized-arrays.ushort ;
+specialized-arrays ;
+SPECIALIZED-ARRAY: ushort
IN: windows.shell32
CONSTANT: CSIDL_DESKTOP HEX: 00
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.strings classes.struct
io.encodings.utf8 kernel namespaces sequences
-specialized-arrays.int x11 x11.constants x11.xlib ;
+specialized-arrays x11 x11.constants x11.xlib ;
+SPECIALIZED-ARRAY: int
IN: x11.clipboard
! This code was based on by McCLIM's Backends/CLX/port.lisp
!
! based on glx.h from xfree86, and some of glxtokens.h
USING: alien alien.c-types alien.syntax x11 x11.xlib x11.syntax
-namespaces make kernel sequences parser words specialized-arrays.int
-accessors ;
+namespaces make kernel sequences parser words
+specialized-arrays accessors ;
+SPECIALIZED-ARRAY: int
IN: x11.glx
LIBRARY: glx
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings arrays byte-arrays
hashtables io io.encodings.string kernel math namespaces
-sequences strings continuations x11 x11.xlib specialized-arrays.uint
-accessors io.encodings.utf16n ;
+sequences strings continuations x11 x11.xlib
+specialized-arrays accessors io.encodings.utf16n ;
+SPECIALIZED-ARRAY: uint
IN: x11.xim
SYMBOL: xim
USING: kernel math namespaces make tools.test vectors sequences
sequences.private hashtables io prettyprint assocs
-continuations specialized-arrays.double ;
+continuations specialized-arrays ;
+SPECIALIZED-ARRAY: double
IN: assocs.tests
[ t ] [ H{ } dup assoc-subset? ] unit-test
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 ;
[ [ "slots" word-prop ] dip = ]
bi-curry* bi and ;
-: valid-superclass? ( class -- ? )
- [ tuple-class? ] [ tuple eq? ] bi or ;
+GENERIC: valid-superclass? ( class -- ? )
+
+M: tuple-class valid-superclass? drop t ;
+
+M: builtin-class valid-superclass? tuple eq? ;
+
+M: class valid-superclass? drop f ;
: check-superclass ( superclass -- )
dup valid-superclass? [ bad-superclass ] unless drop ;
-USING: effects tools.test prettyprint accessors sequences ;
+USING: effects kernel tools.test prettyprint accessors
+quotations sequences ;
IN: effects.tests
[ t ] [ 1 1 <effect> 2 2 <effect> effect<= ] unit-test
[ t ] [ (( -- )) (( -- )) compose-effects (( -- )) effect= ] unit-test
[ t ] [ (( -- * )) (( -- )) compose-effects (( -- * )) effect= ] unit-test
[ t ] [ (( -- )) (( -- * )) compose-effects (( -- * )) effect= ] unit-test
+
+[ { object object } ] [ (( a b -- )) effect-in-types ] unit-test
+[ { object sequence } ] [ (( a b: sequence -- )) effect-in-types ] unit-test
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.parser math.order namespaces make sequences strings
-words assocs combinators accessors arrays ;
+words assocs combinators accessors arrays quotations ;
IN: effects
TUPLE: effect { in read-only } { out read-only } { terminated? read-only } ;
")" %
] "" make ;
+GENERIC: effect>type ( obj -- type )
+M: object effect>type drop object ;
+M: word effect>type ;
+! attempting to specialize on callable breaks compiling
+! M: effect effect>type drop callable ;
+M: pair effect>type second effect>type ;
+
GENERIC: stack-effect ( word -- effect/f )
M: word stack-effect "declared-effect" word-prop ;
[ [ [ "obj" ] replicate ] bi@ ] dip
effect boa
] if ; inline
+
+: effect-in-types ( effect -- input-types )
+ in>> [ effect>type ] map ;
+: effect-out-types ( effect -- input-types )
+ out>> [ effect>type ] map ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: lexer sets sequences kernel splitting effects
-combinators arrays ;
+combinators arrays vocabs.parser classes ;
IN: effects.parser
DEFER: parse-effect
dup { f "(" "((" } member? [ bad-effect ] [
":" ?tail [
scan {
- { "(" [ ")" parse-effect ] }
- { f [ ")" unexpected-eof ] }
+ { [ dup "(" = ] [ drop ")" parse-effect ] }
+ { [ dup search class? ] [ search ] }
+ { [ dup f = ] [ ")" unexpected-eof ] }
[ bad-effect ]
- } case 2array
+ } cond 2array
] when
] if
] if ;
-USING: tools.test math math.functions math.constants generic.standard
-generic.single strings sequences arrays kernel accessors words
-specialized-arrays.double byte-arrays bit-arrays parser namespaces
-make quotations stack-checker vectors growable hashtables sbufs
-prettyprint byte-vectors bit-vectors specialized-vectors.double
+USING: tools.test math math.functions math.constants
+generic.standard generic.single strings sequences arrays kernel
+accessors words byte-arrays bit-arrays parser namespaces make
+quotations stack-checker vectors growable hashtables sbufs
+prettyprint byte-vectors bit-vectors specialized-vectors
definitions generic sets graphs assocs grouping see eval ;
+SPECIALIZED-VECTOR: double
IN: generic.single.tests
GENERIC: lo-tag-test ( obj -- obj' )
[ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test
[ 5 ] [ 10.5 1.9 /i ] unit-test
+
+[ t ] [ 0/0. 0/0. unordered? ] unit-test
+[ t ] [ 1.0 0/0. unordered? ] unit-test
+[ t ] [ 0/0. 1.0 unordered? ] unit-test
+[ f ] [ 1.0 1.0 unordered? ] unit-test
+
double>bits 52 2^ 1 - bitand ; inline
M: float fp-nan?
- dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline
+ dup float= not ;
M: float fp-qnan?
dup fp-nan? [ fp-nan-payload 51 2^ bitand zero? not ] [ drop f ] if ; inline
] if
] if ; inline
+M: float unordered? [ fp-nan? ] bi@ or ; inline
+
M: float prev-float ( m -- n )
double>bits
dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
MATH: <= ( x y -- ? ) foldable
MATH: > ( x y -- ? ) foldable
MATH: >= ( x y -- ? ) foldable
+MATH: unordered? ( x y -- ? ) foldable
+
+M: object unordered? 2drop f ;
MATH: + ( x y -- z ) foldable
MATH: - ( x y -- z ) foldable
-USING: kernel math math.parser sequences tools.test ;
+USING: kernel literals math math.parser sequences tools.test ;
IN: math.parser.tests
[ f ]
[ "-3/4" ] [ -3/4 number>string ] unit-test
[ "-1-1/4" ] [ -5/4 number>string ] unit-test
+
+[ "1.0p0" ] [ 1.0 >hex ] unit-test
+[ "1.8p2" ] [ 6.0 >hex ] unit-test
+[ "1.8p-2" ] [ 0.375 >hex ] unit-test
+[ "-1.8p2" ] [ -6.0 >hex ] unit-test
+[ "1.8p10" ] [ 1536.0 >hex ] unit-test
+[ "0.0" ] [ 0.0 >hex ] unit-test
+[ "1.0p-1074" ] [ 1 bits>double >hex ] unit-test
+[ "-0.0" ] [ -0.0 >hex ] unit-test
+
+[ 1.0 ] [ "1.0" hex> ] unit-test
+[ 15.5 ] [ "f.8" hex> ] unit-test
+[ 15.53125 ] [ "f.88" hex> ] unit-test
+[ -15.5 ] [ "-f.8" hex> ] unit-test
+[ 15.5 ] [ "f.8p0" hex> ] unit-test
+[ -15.5 ] [ "-f.8p0" hex> ] unit-test
+[ 62.0 ] [ "f.8p2" hex> ] unit-test
+[ 3.875 ] [ "f.8p-2" hex> ] unit-test
+[ $[ 1 bits>double ] ] [ "1.0p-1074" hex> ] unit-test
+[ 0.0 ] [ "1.0p-1075" hex> ] unit-test
+[ 1/0. ] [ "1.0p1024" hex> ] unit-test
+[ -1/0. ] [ "-1.0p1024" hex> ] unit-test
+
string>natural
] if ; inline
-: string>float ( str -- n/f )
+: dec>float ( str -- n/f )
[ CHAR: , eq? not ] filter
>byte-array 0 suffix (string>float) ;
+: hex>float-parts ( str -- neg? mantissa-str expt )
+ "-" ?head swap "p" split1 [ 10 base> ] [ 0 ] if* ;
+
+: make-mantissa ( str -- bits )
+ 16 base> dup log2 52 swap - shift ;
+
+: combine-hex-float-parts ( neg? mantissa expt -- float )
+ dup 2046 > [ 2drop -1/0. 1/0. ? ] [
+ dup 0 <= [ 1 - shift 0 ] when
+ [ HEX: 8000,0000,0000,0000 0 ? ]
+ [ 52 2^ 1 - bitand ]
+ [ 52 shift ] tri* bitor bitor
+ bits>double
+ ] if ;
+
+: hex>float ( str -- n/f )
+ hex>float-parts
+ [ "." split1 [ append make-mantissa ] [ drop 16 base> log2 ] 2bi ]
+ [ + 1023 + ] bi*
+ combine-hex-float-parts ;
+
+: base>float ( str base -- n/f )
+ {
+ { 10 [ dec>float ] }
+ { 16 [ hex>float ] }
+ [ "Floats can only be converted from strings in base 10 or 16" throw ]
+ } case ;
+
: number-char? ( char -- ? )
"0123456789ABCDEFabcdef." member? ;
PRIVATE>
+: string>float ( str -- n/f )
+ 10 base>float ;
+
: base> ( str radix -- n/f )
over numeric-looking? [
over [ "/." member? ] find nip {
{ CHAR: / [ string>ratio ] }
- { CHAR: . [ drop string>float ] }
+ { CHAR: . [ base>float ] }
[ drop string>integer ]
} case
] [ 2drop f ] if ;
[ ".0" append ]
} cond ;
-: float>string ( n -- str )
+<PRIVATE
+
+: mantissa-expt-normalize ( mantissa expt -- mantissa' expt' )
+ dup zero?
+ [ over log2 52 swap - [ shift 52 2^ 1 - bitand ] [ 1022 + - ] bi-curry bi* ]
+ [ 1023 - ] if ;
+
+: mantissa-expt ( float -- mantissa expt )
+ [ 52 2^ 1 - bitand ]
+ [ -0.0 double>bits bitnot bitand -52 shift ] bi
+ mantissa-expt-normalize ;
+
+: float>hex-sign ( bits -- str )
+ -0.0 double>bits bitand zero? "" "-" ? ;
+
+: float>hex-value ( mantissa -- str )
+ 16 >base [ CHAR: 0 = ] trim-tail [ "0" ] [ ] if-empty "1." prepend ;
+
+: float>hex-expt ( mantissa -- str )
+ 10 >base "p" prepend ;
+
+: float>hex ( n -- str )
+ double>bits
+ [ float>hex-sign ] [
+ mantissa-expt [ float>hex-value ] [ float>hex-expt ] bi*
+ ] bi 3append ;
+
+: float>decimal ( n -- str )
(float>string)
[ 0 = ] trim-tail >string
fix-float ;
+: float>base ( n base -- str )
+ {
+ { 10 [ float>decimal ] }
+ { 16 [ float>hex ] }
+ [ "Floats can only be converted to strings in base 10 or 16" throw ]
+ } case ;
+
+PRIVATE>
+
+: float>string ( n -- str )
+ 10 float>base ;
+
M: float >base
- drop {
- { [ dup fp-nan? ] [ drop "0/0." ] }
- { [ dup 1/0. = ] [ drop "1/0." ] }
- { [ dup -1/0. = ] [ drop "-1/0." ] }
- { [ dup double>bits HEX: 8000000000000000 = ] [ drop "-0.0" ] }
- [ float>string ]
+ {
+ { [ over fp-nan? ] [ 2drop "0/0." ] }
+ { [ over 1/0. = ] [ 2drop "1/0." ] }
+ { [ over -1/0. = ] [ 2drop "-1/0." ] }
+ { [ over 0.0 fp-bitwise= ] [ 2drop "0.0" ] }
+ { [ over -0.0 fp-bitwise= ] [ 2drop "-0.0" ] }
+ [ float>base ]
} cond ;
: number>string ( n -- str ) 10 >base ;
INSTANCE: f immutable-sequence
! Integers used to support the sequence protocol
-M: integer length ; inline deprecated
-M: integer nth-unsafe drop ; inline deprecated
+M: integer length ; inline
+M: integer nth-unsafe drop ; inline
INSTANCE: integer immutable-sequence
: last-index-from ( obj i seq -- n )
rot [ = ] curry find-last-from drop ;
+<PRIVATE
+
: (indices) ( elt i obj accum -- )
[ swap [ = ] dip ] dip [ push ] 2curry when ; inline
+PRIVATE>
+
: indices ( obj seq -- indices )
swap V{ } clone
[ [ (indices) ] 2curry each-index ] keep ;
{ $description "Parses a complex number given in rectangular form as a pair of real numbers. Literal complex numbers are terminated by " { $link POSTPONE: } } "." } ;
HELP: T{
-{ $syntax "T{ class slots... }" }
+{ $syntax "T{ class }" "T{ class f slot-values... }" "T{ class { slot-name slot-value } ... }" }
{ $values { "class" "a tuple class word" } { "slots" "slot values" } }
{ $description "Marks the beginning of a literal tuple."
$nl
[ manifest get (>>current-vocab) ]
[ words>> <extra-words> (add-qualified) ] bi ;
+: with-current-vocab ( name quot -- )
+ manifest get clone manifest [
+ [ set-current-vocab ] dip call
+ ] with-variable ; inline
+
TUPLE: no-current-vocab ;
: no-current-vocab ( -- vocab )
alien.marshall.private alien.strings byte-arrays classes
combinators combinators.short-circuit destructors fry
io.encodings.utf8 kernel libc sequences
-specialized-arrays.alien specialized-arrays.bool
-specialized-arrays.char specialized-arrays.double
-specialized-arrays.float specialized-arrays.int
-specialized-arrays.long specialized-arrays.longlong
-specialized-arrays.short specialized-arrays.uchar
-specialized-arrays.uint specialized-arrays.ulong
-specialized-arrays.ulonglong specialized-arrays.ushort strings
-unix.utilities vocabs.parser words libc.private struct-arrays
-locals generalizations math ;
+specialized-arrays strings unix.utilities vocabs.parser
+words libc.private locals generalizations math ;
+SPECIALIZED-ARRAY: bool
+SPECIALIZED-ARRAY: char
+SPECIALIZED-ARRAY: double
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: long
+SPECIALIZED-ARRAY: longlong
+SPECIALIZED-ARRAY: short
+SPECIALIZED-ARRAY: uchar
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: ulong
+SPECIALIZED-ARRAY: ulonglong
+SPECIALIZED-ARRAY: ushort
+SPECIALIZED-ARRAY: void*
IN: alien.marshall
<< primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ]
{ [ dup not ] [ ] }
{ [ dup byte-array? ] [ malloc-byte-array ] }
{ [ dup alien-wrapper? ] [ underlying>> ] }
- { [ dup struct-array? ] [ underlying>> ] }
} cond ;
: marshall-primitive ( n -- n )
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.inline arrays
combinators fry functors kernel lexer libc macros math
-sequences specialized-arrays.alien libc.private
+sequences specialized-arrays libc.private
combinators.short-circuit ;
+SPECIALIZED-ARRAY: void*
IN: alien.marshall.private
: bool>arg ( ? -- 1/0/obj )
PRIVATE>
-: (run-benchmark) ( vocab -- time )
+: run-benchmark ( vocab -- time )
[ 5 ] dip '[ gc [ _ run ] benchmark ] replicate infimum ;
-: run-benchmark ( vocab -- )
+<PRIVATE
+
+: record-benchmark ( vocab -- )
[ "=== " write print flush ] [
- [ [ require ] [ (run-benchmark) ] [ ] tri timings ]
+ [ [ require ] [ run-benchmark ] [ ] tri timings ]
[ swap errors ]
recover get set-at
] bi ;
+PRIVATE>
+
: run-benchmarks ( -- timings errors )
[
V{ } clone timings set
V{ } clone errors set
"benchmark" child-vocab-names
[ find-vocab-root ] filter
- [ run-benchmark ] each
+ [ record-benchmark ] each
timings get
errors get
] with-scope ;
-USING: sequences hints kernel math specialized-arrays.int fry ;
+USING: sequences kernel math specialized-arrays fry ;
+SPECIALIZED-ARRAY: int
IN: benchmark.dawes
! Phil Dawes's performance problem
: count-ones ( int-array -- n ) [ 1 = ] count ; inline
-HINTS: count-ones int-array ;
-
: make-int-array ( -- int-array )
- 120000 [ 255 bitand ] int-array{ } map-as ;
+ 120000 [ 255 bitand ] int-array{ } map-as ; inline
: dawes-benchmark ( -- )
- make-int-array 200 swap '[ _ count-ones ] replicate drop ;
+ 200 make-int-array '[ _ count-ones ] replicate drop ;
MAIN: dawes-benchmark
USING: make math sequences splitting grouping
-kernel columns specialized-arrays.double bit-arrays ;
+kernel columns specialized-arrays bit-arrays ;
+SPECIALIZED-ARRAY: double
IN: benchmark.dispatch2
: sequences ( -- seq )
USING: sequences math mirrors splitting grouping
kernel make assocs alien.syntax columns
-specialized-arrays.double bit-arrays ;
+specialized-arrays bit-arrays ;
+SPECIALIZED-ARRAY: double
IN: benchmark.dispatch3
GENERIC: g ( obj -- str )
! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2
USING: math kernel io io.files locals multiline assocs sequences
-sequences.private benchmark.reverse-complement hints io.encodings.ascii
-byte-arrays specialized-arrays.double ;
+sequences.private benchmark.reverse-complement hints
+io.encodings.ascii byte-arrays specialized-arrays ;
+SPECIALIZED-ARRAY: double
IN: benchmark.fasta
CONSTANT: IM 139968
--- /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 classes.struct
+specialized-arrays ;
+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 } ;
+
+SPECIALIZED-ARRAY: body
+
+: <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
+
+: 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> ]
+ body-array{ } output>sequence
+ dup 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 -- )
+ [ '[ _ 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 [ 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
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors specialized-arrays.double fry kernel locals math
-math.constants math.functions math.vectors prettyprint combinators.smart
-sequences hints arrays ;
+USING: accessors specialized-arrays fry kernel locals math
+math.constants math.functions math.vectors prettyprint
+combinators.smart sequences hints arrays ;
+SPECIALIZED-ARRAY: double
IN: benchmark.nbody
: solar-mass ( -- x ) 4 pi sq * ; inline
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Factor port of the raytracer benchmark from
+! http://www.ffconsultancy.com/free/ray_tracer/languages.html
+
+USING: arrays accessors io io.files io.files.temp
+io.encodings.binary kernel math math.constants math.functions
+math.vectors math.vectors.simd math.parser make sequences
+sequences.private words hints classes.struct ;
+IN: benchmark.raytracer-simd
+
+! parameters
+
+! Normalized { -1 -3 2 }.
+CONSTANT: light
+ double-4{
+ -0.2672612419124244
+ -0.8017837257372732
+ 0.5345224838248488
+ 0.0
+ }
+
+CONSTANT: oversampling 4
+
+CONSTANT: levels 3
+
+CONSTANT: size 200
+
+: delta ( -- n ) epsilon sqrt ; inline
+
+TUPLE: ray { orig double-4 read-only } { dir double-4 read-only } ;
+
+C: <ray> ray
+
+TUPLE: hit { normal double-4 read-only } { lambda float read-only } ;
+
+C: <hit> hit
+
+GENERIC: intersect-scene ( hit ray scene -- hit )
+
+TUPLE: sphere { center double-4 read-only } { radius float read-only } ;
+
+C: <sphere> sphere
+
+: sphere-v ( sphere ray -- v )
+ [ center>> ] [ orig>> ] bi* v- ; inline
+
+: sphere-b ( v ray -- b )
+ dir>> v. ; inline
+
+: sphere-d ( sphere b v -- d )
+ [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline
+
+: -+ ( x y -- x-y x+y )
+ [ - ] [ + ] 2bi ; inline
+
+: sphere-t ( b d -- t )
+ -+ dup 0.0 <
+ [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
+
+: sphere-b&v ( sphere ray -- b v )
+ [ sphere-v ] [ nip ] 2bi
+ [ sphere-b ] [ drop ] 2bi ; inline
+
+: ray-sphere ( sphere ray -- t )
+ [ drop ] [ sphere-b&v ] 2bi
+ [ drop ] [ sphere-d ] 3bi
+ dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline
+
+: if-ray-sphere ( hit ray sphere quot -- hit )
+ #! quot: hit ray sphere l -- hit
+ [
+ [ ] [ swap ray-sphere nip ] [ 2drop lambda>> ] 3tri
+ [ drop ] [ < ] 2bi
+ ] dip [ 3drop ] if ; inline
+
+: sphere-n ( ray sphere l -- n )
+ [ [ orig>> ] [ dir>> ] bi ] [ center>> ] [ ] tri*
+ swap [ v*n ] dip v- v+ ; inline
+
+M: sphere intersect-scene ( hit ray sphere -- hit )
+ [ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
+
+HINTS: M\ sphere intersect-scene { hit ray sphere } ;
+
+TUPLE: group < sphere { objs array read-only } ;
+
+: <group> ( objs bound -- group )
+ [ center>> ] [ radius>> ] bi rot group boa ; inline
+
+: make-group ( bound quot -- )
+ swap [ { } make ] dip <group> ; inline
+
+M: group intersect-scene ( hit ray group -- hit )
+ [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ;
+
+HINTS: M\ group intersect-scene { hit ray group } ;
+
+CONSTANT: initial-hit T{ hit f double-4{ 0.0 0.0 0.0 0.0 } 1/0. }
+
+: initial-intersect ( ray scene -- hit )
+ [ initial-hit ] 2dip intersect-scene ; inline
+
+: ray-o ( ray hit -- o )
+ [ [ orig>> ] [ normal>> delta v*n ] bi* ]
+ [ [ dir>> ] [ lambda>> ] bi* v*n ]
+ 2bi v+ v+ ; inline
+
+: sray-intersect ( ray scene hit -- ray )
+ swap [ ray-o light vneg <ray> ] dip initial-intersect ; inline
+
+: ray-g ( hit -- g ) normal>> light v. ; inline
+
+: cast-ray ( ray scene -- g )
+ 2dup initial-intersect dup lambda>> 1/0. = [
+ 3drop 0.0
+ ] [
+ [ sray-intersect lambda>> 1/0. = ] keep swap
+ [ ray-g neg ] [ drop 0.0 ] if
+ ] if ; inline
+
+: create-center ( c r d -- c2 )
+ [ 3.0 12.0 sqrt / * ] dip n*v v+ ; inline
+
+DEFER: create ( level c r -- scene )
+
+: create-step ( level c r d -- scene )
+ over [ create-center ] dip 2.0 / [ 1 - ] 2dip create ;
+
+: create-offsets ( quot -- )
+ {
+ double-4{ -1.0 1.0 -1.0 0.0 }
+ double-4{ 1.0 1.0 -1.0 0.0 }
+ double-4{ -1.0 1.0 1.0 0.0 }
+ double-4{ 1.0 1.0 1.0 0.0 }
+ } swap each ; inline
+
+: create-bound ( c r -- sphere ) 3.0 * <sphere> ;
+
+: create-group ( level c r -- scene )
+ 2dup create-bound [
+ 2dup <sphere> ,
+ [ [ 3dup ] dip create-step , ] create-offsets 3drop
+ ] make-group ;
+
+: create ( level c r -- scene )
+ pick 1 = [ <sphere> nip ] [ create-group ] if ;
+
+: ss-point ( dx dy -- point )
+ [ oversampling /f ] bi@ 0.0 0.0 double-4-boa ;
+
+: ss-grid ( -- ss-grid )
+ oversampling [ oversampling [ ss-point ] with map ] map ;
+
+: ray-grid ( point ss-grid -- ray-grid )
+ [
+ [ v+ normalize double-4{ 0.0 0.0 -4.0 0.0 } swap <ray> ] with map
+ ] with map ;
+
+: ray-pixel ( scene point -- n )
+ ss-grid ray-grid [ 0.0 ] 2dip
+ [ [ swap cast-ray + ] with each ] with each ;
+
+: pixel-grid ( -- grid )
+ size reverse [
+ size [
+ [ size 0.5 * - ] bi@ swap size
+ 0.0 double-4-boa
+ ] with map
+ ] map ;
+
+: pgm-header ( w h -- )
+ "P5\n" % swap # " " % # "\n255\n" % ;
+
+: pgm-pixel ( n -- ) 255 * 0.5 + >fixnum , ;
+
+: ray-trace ( scene -- pixels )
+ pixel-grid [ [ ray-pixel ] with map ] with map ;
+
+: run ( -- string )
+ levels double-4{ 0.0 -1.0 0.0 0.0 } 1.0 create ray-trace [
+ size size pgm-header
+ [ [ oversampling sq / pgm-pixel ] each ] each
+ ] B{ } make ;
+
+: raytracer-main ( -- )
+ run "raytracer.pnm" temp-file binary set-file-contents ;
+
+MAIN: raytracer-main
! Factor port of the raytracer benchmark from
! 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 ;
+USING: arrays accessors specialized-arrays io io.files
+io.files.temp io.encodings.binary kernel math math.constants
+math.functions math.vectors math.parser make sequences
+sequences.private words hints ;
+SPECIALIZED-ARRAY: double
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 } ;
--- /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 io math math.functions math.parser math.vectors
+math.vectors.simd sequences specialized-arrays ;
+SPECIALIZED-ARRAY: float-4
+IN: benchmark.simd-1
+
+: <point> ( n -- float-4 )
+ >float [ sin ] [ cos 3 * ] [ sin sq 2 / ] tri
+ 0.0 float-4-boa ; inline
+
+: make-points ( len -- points )
+ iota [ <point> ] float-4-array{ } map-as ; inline
+
+: normalize-points ( points -- )
+ [ normalize ] change-each ; inline
+
+: max-points ( points -- point )
+ [ ] [ vmax ] map-reduce ; inline
+
+: print-point ( point -- )
+ [ number>string ] { } map-as ", " join print ; inline
+
+: simd-benchmark ( len -- )
+ >fixnum make-points [ normalize-points ] [ max-points ] bi print-point ;
+
+: main ( -- )
+ 5000000 simd-benchmark ;
+
+MAIN: main
! Factor port of
! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
-USING: specialized-arrays.double kernel math math.functions
+USING: specialized-arrays kernel math math.functions
math.vectors sequences sequences.private prettyprint words hints
locals ;
+SPECIALIZED-ARRAY: double
IN: benchmark.spectral-norm
:: inner-loop ( u n quot -- seq )
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes.struct combinators.smart fry kernel
math math.functions math.order math.parser sequences
-struct-arrays io ;
+specialized-arrays io ;
IN: benchmark.struct-arrays
STRUCT: point { x float } { y float } { z float } ;
+SPECIALIZED-ARRAY: point
+
: xyz ( point -- x y z )
[ x>> ] [ y>> ] [ z>> ] tri ; inline
1 + ; inline
: make-points ( len -- points )
- point <struct-array> dup 0 [ init-point ] reduce drop ; inline
+ <point-array> dup 0 [ init-point ] reduce drop ; inline
: point-norm ( point -- norm )
[ xyz [ absq ] tri@ ] sum-outputs sqrt ; inline
USING: alien.c-types continuations destructors kernel
-opengl opengl.gl bunny.model specialized-arrays.float
-accessors ;
+opengl opengl.gl bunny.model specialized-arrays accessors ;
+SPECIALIZED-ARRAY: float
IN: bunny.fixed-pipeline
TUPLE: bunny-fixed-pipeline ;
http.client io io.encodings.ascii io.files io.files.temp kernel
math math.matrices math.parser math.vectors opengl
opengl.capabilities opengl.gl opengl.demo-support sequences
-splitting vectors words specialized-arrays.float
-specialized-arrays.uint ;
+splitting vectors words specialized-arrays ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: uint
IN: bunny.model
: numbers ( str -- seq )
! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types arrays classes.struct combinators
-combinators.short-circuit game-worlds gpu gpu.buffers gpu.util.wasd
-gpu.framebuffers gpu.render gpu.shaders gpu.state gpu.textures gpu.util
-grouping http.client images images.loader io io.encodings.ascii io.files
-io.files.temp kernel math math.matrices math.parser math.vectors
-method-chains sequences specialized-arrays.float specialized-vectors.uint
-splitting struct-vectors threads ui ui.gadgets ui.gadgets.worlds
-ui.pixel-formats ;
+combinators.short-circuit game-worlds gpu gpu.buffers
+gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state
+gpu.textures gpu.util grouping http.client images images.loader
+io io.encodings.ascii io.files io.files.temp kernel math
+math.matrices math.parser math.vectors method-chains sequences
+splitting threads ui ui.gadgets ui.gadgets.worlds
+ui.pixel-formats specialized-arrays specialized-vectors ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-VECTOR: uint
IN: gpu.demos.bunny
GLSL-SHADER-FILE: bunny-vertex-shader vertex-shader "bunny.v.glsl"
{ f float-components 1 f } ;
VERTEX-STRUCT: bunny-vertex-struct bunny-vertex
+SPECIALIZED-VECTOR: bunny-vertex-struct
+
UNIFORM-TUPLE: bunny-uniforms < mvp-uniforms
{ "light-position" vec3-uniform f }
{ "color" vec4-uniform f }
] when* ;
: parse-bunny-model ( -- vertexes indexes )
- 100000 bunny-vertex-struct <struct-vector>
+ 100000 <bunny-vertex-struct-vector>
100000 <uint-vector>
(parse-bunny-model) ;
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-name "gpu.demos.bunny" }
+ { deploy-word-defs? f }
+ { deploy-io 3 }
+ { "stop-after-last-window?" t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-threads? t }
+ { deploy-c-types? f }
+ { deploy-reflection 2 }
+ { deploy-unicode? f }
+ { deploy-ui? t }
+}
destructors gpu gpu.buffers gpu.private gpu.textures
gpu.textures.private images kernel locals math math.rectangles opengl
opengl.framebuffers opengl.gl opengl.textures sequences
-specialized-arrays.int specialized-arrays.uint
-ui.gadgets.worlds variants ;
+specialized-arrays ui.gadgets.worlds variants ;
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: uint
IN: gpu.framebuffers
SINGLETON: system-framebuffer
USING: alien alien.syntax byte-arrays classes gpu.buffers
gpu.framebuffers gpu.shaders gpu.textures help.markup
help.syntax images kernel math multiline sequences
-specialized-arrays.alien specialized-arrays.uint
-specialized-arrays.ulong strings ;
+specialized-arrays strings ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: ulong
+SPECIALIZED-ARRAY: void*
IN: gpu.render
HELP: <index-elements>
gpu.textures gpu.textures.private half-floats images kernel
lexer locals math math.order math.parser namespaces opengl
opengl.gl parser quotations sequences slots sorting
-specialized-arrays.alien specialized-arrays.float specialized-arrays.int
-specialized-arrays.uint strings ui.gadgets.worlds variants
+specialized-arrays strings ui.gadgets.worlds variants
vocabs.parser words ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: void*
IN: gpu.render
UNION: ?integer integer POSTPONE: f ;
! (c)2009 Joe Groff bsd license
-USING: accessors alien alien.c-types alien.strings
-arrays assocs byte-arrays classes.mixin classes.parser
-classes.singleton classes.struct combinators
-combinators.short-circuit definitions destructors
-generic.parser gpu gpu.buffers hashtables images
+USING: accessors alien alien.c-types alien.strings arrays assocs
+byte-arrays classes.mixin classes.parser classes.singleton
+classes.struct combinators combinators.short-circuit definitions
+destructors generic.parser gpu gpu.buffers hashtables images
io.encodings.ascii io.files io.pathnames kernel lexer literals
locals math math.parser memoize multiline namespaces opengl
opengl.gl opengl.shaders parser quotations sequences
-specialized-arrays.alien specialized-arrays.int splitting
-strings tr ui.gadgets.worlds variants vectors vocabs vocabs.loader
-vocabs.parser words words.constant ;
+specialized-arrays splitting strings tr ui.gadgets.worlds
+variants vectors vocabs vocabs.loader vocabs.parser words
+words.constant ;
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: void*
IN: gpu.shaders
VARIANT: shader-kind
! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types arrays byte-arrays combinators gpu
kernel literals math math.rectangles opengl opengl.gl sequences
-variants specialized-arrays.int specialized-arrays.float ;
+variants specialized-arrays ;
+SPECIALIZED-ARRAY: int
+SPECIALIZED-ARRAY: float
IN: gpu.state
UNION: ?rect rect POSTPONE: f ;
USING: accessors alien.c-types arrays byte-arrays combinators
destructors fry gpu gpu.buffers images kernel locals math
opengl opengl.gl opengl.textures sequences
-specialized-arrays.float ui.gadgets.worlds variants ;
+specialized-arrays ui.gadgets.worlds variants ;
+SPECIALIZED-ARRAY: float
IN: gpu.textures
TUPLE: texture < gpu-object
! (c)2009 Joe Groff bsd license
USING: gpu.buffers gpu.render gpu.shaders gpu.textures images kernel
-specialized-arrays.float ;
+specialized-arrays ;
+SPECIALIZED-ARRAY: float
IN: gpu.util
CONSTANT: environment-cube-map-mv-matrices
gpu.render gpu.state kernel literals
locals math math.constants math.functions math.matrices
math.order math.vectors opengl.gl sequences
-specialized-arrays.float ui ui.gadgets.worlds ;
+ui ui.gadgets.worlds specialized-arrays ;
+SPECIALIZED-ARRAY: float
IN: gpu.util.wasd
UNIFORM-TUPLE: mvp-uniforms
! (c)2009 Joe Groff bsd license
USING: accessors arrays destructors kernel math opengl
-opengl.gl sequences sequences.product specialized-arrays.float ;
+opengl.gl sequences sequences.product specialized-arrays ;
+SPECIALIZED-ARRAY: float
IN: grid-meshes
TUPLE: grid-mesh dim buffer row-length ;
-USING: alien.c-types alien.syntax half-floats kernel math tools.test ;
+USING: alien.c-types alien.syntax half-floats kernel math tools.test
+specialized-arrays ;
+SPECIALIZED-ARRAY: half
IN: half-floats.tests
[ HEX: 0000 ] [ 0.0 half>bits ] unit-test
! (c)2009 Joe Groff bsd license
-USING: accessors alien.c-types alien.syntax kernel math math.order
-specialized-arrays.functor ;
+USING: accessors alien.c-types alien.syntax kernel math math.order ;
IN: half-floats
: half>bits ( float -- bits )
[ *ushort bits>half ] >>boxer-quot
drop
-"half" define-array
-
>>
! Copyright (C) 2009 Tim Wawrzynczak, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences io io.encodings.binary io.files io.pathnames
-strings kernel math io.mmap io.mmap.uchar accessors
-combinators math.ranges unicode.categories byte-arrays
-io.encodings.string io.encodings.utf16 assocs math.parser
-combinators.short-circuit fry namespaces combinators.smart
-splitting io.encodings.ascii arrays io.files.info unicode.case
-io.directories.search literals math.functions continuations ;
+strings kernel math io.mmap accessors combinators math.ranges
+unicode.categories byte-arrays io.encodings.string
+io.encodings.utf16 assocs math.parser combinators.short-circuit
+fry namespaces combinators.smart splitting io.encodings.ascii
+arrays io.files.info unicode.case io.directories.search literals
+math.functions continuations ;
IN: id3
<PRIVATE
CONSTANT: id3v1-length 128
CONSTANT: id3v1-offset 128
CONSTANT: id3v1+-length 227
-CONSTANT: id3v1+-offset $[ 128 227 + ]
+: id3v1+-offset ( -- n ) id3v1-length id3v1+-length + ; inline
: id3v1? ( seq -- ? )
{
: mp3>id3 ( path -- id3/f )
[
- [ <id3> ] dip
- {
- [ dup id3v1? [ read-v1-tags merge-id3v1 ] [ drop ] if ]
- [ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
- [ dup id3v2? [ read-v2-tags ] [ drop ] if ]
- } cleave
- ] with-mapped-uchar-file-reader ;
+ [ <id3> ] dip "uchar" <mapped-array>
+ [ dup id3v1? [ read-v1-tags merge-id3v1 ] [ drop ] if ]
+ [ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ]
+ [ dup id3v2? [ read-v2-tags ] [ drop ] if ]
+ tri
+ ] with-mapped-file-reader ;
: find-id3-frame ( id3 name -- obj/f )
swap frames>> at* [ data>> ] when ;
! Copyright (C) 2009 Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors grouping sequences combinators math
-byte-arrays fry specialized-arrays.uint specialized-arrays.ushort
-specialized-arrays.float images half-floats ;
+byte-arrays fry images half-floats specialized-arrays ;
+SPECIALIZED-ARRAY: uint
+SPECIALIZED-ARRAY: ushort
+SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAY: half
IN: images.normalization
<PRIVATE
USING: accessors alien.c-types jamshred.game jamshred.oint
jamshred.player jamshred.tunnel kernel math math.constants
math.functions math.vectors opengl opengl.gl opengl.glu
-opengl.demo-support sequences specialized-arrays.float ;
+opengl.demo-support sequences specialized-arrays ;
+SPECIALIZED-ARRAY: float
IN: jamshred.gl
CONSTANT: min-vertices 6
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors.constants combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle specialized-arrays.float strings system ;
+USING: accessors colors.constants combinators jamshred.log
+jamshred.oint jamshred.sound jamshred.tunnel kernel locals math
+math.constants math.order math.ranges math.vectors math.matrices
+sequences shuffle specialized-arrays strings system ;
+SPECIALIZED-ARRAY: float
IN: jamshred.player
TUPLE: player < oint
! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences specialized-arrays.float tools.test ;
+USING: accessors arrays jamshred.oint jamshred.tunnel kernel
+math.vectors sequences specialized-arrays tools.test ;
+SPECIALIZED-ARRAY: float
IN: jamshred.tunnel.tests
[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
USING: accessors arrays colors combinators fry jamshred.oint
kernel literals locals math math.constants math.matrices
math.order math.quadratic math.ranges math.vectors random
-sequences specialized-arrays.float vectors ;
+sequences specialized-arrays vectors ;
FROM: jamshred.oint => distance ;
+SPECIALIZED-ARRAY: float
IN: jamshred.tunnel
CONSTANT: n-segments 5000
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien arrays assocs compiler.units effects
io.backend io.pathnames kernel llvm.core llvm.jit llvm.reader
-llvm.types make namespaces sequences specialized-arrays.alien
+llvm.types make namespaces sequences specialized-arrays
vocabs words ;
-
+SPECIALIZED-ARRAY: void*
IN: llvm.invoker
! get function name, ret type, param types and names
! Copyright (C) 2009 Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators kernel llvm.core
-locals math.parser math multiline
-namespaces parser peg.ebnf sequences
-sequences.deep specialized-arrays.alien strings vocabs words ;
-
+USING: accessors arrays combinators kernel llvm.core locals
+math.parser math multiline namespaces parser peg.ebnf sequences
+sequences.deep specialized-arrays strings vocabs words ;
+SPECIALIZED-ARRAY: void*
IN: llvm.types
! Type resolution strategy:
] with-scope
] unit-test
-[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" } ] [
+[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" "-sse-version=30" } ] [
[
"winnt" target-os set
"x86.32" target-cpu set
target-os get "winnt" = "./factor.com" "./factor" ? ;
: boot-cmd ( -- cmd )
- factor-vm
- "-i=" boot-image-name append
- "-no-user-init"
- 3array ;
+ [
+ factor-vm ,
+ "-i=" boot-image-name append ,
+ "-no-user-init" ,
+ target-cpu get { "x86.32" "x86.64" } member? [ "-sse-version=30" , ] when
+ ] { } make ;
: boot ( -- )
"factor" [
! (c)2009 Joe Groff bsd license
USING: accessors arrays grouping kernel locals math math.order
math.ranges math.vectors math.vectors.homogeneous sequences
-specialized-arrays.float ;
+specialized-arrays ;
+SPECIALIZED-ARRAY: float
IN: nurbs
TUPLE: nurbs-curve
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors arrays alien system combinators alien.syntax namespaces
- alien.c-types sequences vocabs.loader shuffle
- openal.backend specialized-arrays.uint alien.libraries generalizations ;
+USING: kernel accessors arrays alien system combinators
+alien.syntax namespaces alien.c-types sequences vocabs.loader
+shuffle openal.backend alien.libraries generalizations
+specialized-arrays ;
+SPECIALIZED-ARRAY: uint
IN: openal
<< "alut" {
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.ranges math.order
-project-euler.common sequences ;
+project-euler.common sequences layouts ;
IN: project-euler.044
! http://projecteuler.net/index.php?section=problems&id=44
<PRIVATE
: nth-pentagonal ( n -- seq )
- dup 3 * 1 - * 2 / ;
+ dup 3 * 1 - * 2 /i ; inline
: sum-and-diff? ( m n -- ? )
- [ + ] [ - ] 2bi [ pentagonal? ] bi@ and ;
+ [ + ] [ - ] 2bi [ pentagonal? ] bi@ and ; inline
+
+: euler044-step ( min m n -- min' )
+ [ nth-pentagonal ] bi@
+ 2dup sum-and-diff? [ - abs min ] [ 2drop ] if ; inline
PRIVATE>
: euler044 ( -- answer )
- 2500 [1,b] [ nth-pentagonal ] map dup cartesian-product
- [ first2 sum-and-diff? ] filter [ first2 - abs ] [ min ] map-reduce ;
+ most-positive-fixnum >fixnum
+ 2500 [1,b] [
+ dup [1,b] [
+ euler044-step
+ ] with each
+ ] each ;
! [ euler044 ] 10 ave-time
-! 4996 ms ave run time - 87.46 SD (10 trials)
-
-! TODO: this solution is ugly and not very efficient...find a better algorithm
+! 289 ms ave run time - 0.27 SD (10 trials)
SOLUTION: euler044
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel locals make math project-euler.common sequences ;
+USING: kernel locals math project-euler.common sequences ;
IN: project-euler.073
! http://projecteuler.net/index.php?section=problems&id=73
<PRIVATE
-:: (euler073) ( limit lo hi -- )
+:: (euler073) ( counter limit lo hi -- counter' )
[let | m [ lo hi mediant ] |
m denominator limit <= [
- m ,
+ counter 1 +
limit lo m (euler073)
limit m hi (euler073)
- ] when
+ ] [ counter ] if
] ;
PRIVATE>
: euler073 ( -- answer )
- [ 10000 1/3 1/2 (euler073) ] { } make length ;
+ 0 10000 1/3 1/2 (euler073) ;
! [ euler073 ] 10 ave-time
! 20506 ms ave run time - 937.07 SD (10 trials)
! Copyright (c) 2009 Guillaume Nargeot.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.ranges project-euler.common sequences ;
+USING: accessors kernel math math.ranges project-euler.common
+sequences locals ;
IN: project-euler.085
! http://projecteuler.net/index.php?section=problems&id=85
<PRIVATE
: distance ( m -- n )
- 2000000 - abs ;
+ 2000000 - abs ; inline
: rectangles-count ( a b -- n )
- 2dup [ 1 + ] bi@ * * * 4 / ;
+ 2dup [ 1 + ] bi@ * * * 4 /i ; inline
-: unique-products ( a b -- seq )
- tuck [a,b] [
- over dupd [a,b] [ 2array ] with map
- ] map concat nip ;
+:: each-unique-product ( a b quot: ( i j -- ) -- )
+ a b [a,b] [| i |
+ i b [a,b] [| j |
+ i j quot call
+ ] each
+ ] each ; inline
-: max-by-last ( seq seq -- seq )
- [ [ last ] bi@ < ] most ;
+TUPLE: result { area read-only } { distance read-only } ;
-: array2 ( seq -- a b )
- [ first ] [ last ] bi ;
+C: <result> result
-: convert ( seq -- seq )
- array2 [ * ] [ rectangles-count distance ] 2bi 2array ;
+: min-by-distance ( seq seq -- seq )
+ [ [ distance>> ] bi@ < ] most ; inline
+
+: compute-result ( i j -- pair )
+ [ * ] [ rectangles-count distance ] 2bi <result> ; inline
: area-of-nearest ( -- n )
- 1 2000 unique-products
- [ convert ] [ max-by-last ] map-reduce first ;
+ T{ result f 0 2000000 } 1 2000
+ [ compute-result min-by-distance ] each-unique-product area>> ;
PRIVATE>
number>string natural-sort >string "123456789" = ;
: pentagonal? ( n -- ? )
- dup 0 > [ 24 * 1 + sqrt 1 + 6 / 1 mod zero? ] [ drop f ] if ;
+ dup 0 > [ 24 * 1 + sqrt 1 + 6 / 1 mod zero? ] [ drop f ] if ; inline
: penultimate ( seq -- elt )
dup length 2 - swap nth ;
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types combinators kernel locals math math.ranges openal sequences sequences.merged specialized-arrays.uchar specialized-arrays.short ;
+USING: accessors alien.c-types combinators kernel locals math
+math.ranges openal sequences sequences.merged specialized-arrays ;
+SPECIALIZED-ARRAY: uchar
+SPECIALIZED-ARRAY: short
IN: synth.buffers
TUPLE: buffer sample-freq 8bit? id ;
! See http://factorcode.org/license.txt for BSD license.
USING: unix alien alien.c-types kernel math sequences strings
io.backend.unix splitting io.encodings.utf8 io.encodings.string
-specialized-arrays.char ;
+specialized-arrays ;
+SPECIALIZED-ARRAY: char
IN: system-info.linux
: (uname) ( buf -- int )
USING: alien alien.c-types classes.struct accessors kernel
math namespaces windows windows.kernel32 windows.advapi32 words
combinators vocabs.loader system-info.backend system
-alien.strings windows.errors specialized-arrays.ushort ;
+alien.strings windows.errors specialized-arrays ;
+SPECIALIZED-ARRAY: ushort
IN: system-info.windows
: system-info ( -- SYSTEM_INFO )
math math.constants math.functions math.matrices math.order
math.vectors opengl opengl.capabilities opengl.gl
opengl.shaders opengl.textures opengl.textures.private
-sequences sequences.product specialized-arrays.float
+sequences sequences.product specialized-arrays
terrain.generation terrain.shaders ui ui.gadgets
ui.gadgets.worlds ui.pixel-formats game-worlds method-chains
math.affine-transforms noise ui.gestures combinators.short-circuit
destructors grid-meshes ;
+SPECIALIZED-ARRAY: float
IN: terrain
CONSTANT: FOV $[ 2.0 sqrt 1 + ]
--- /dev/null
+Strongly-typed word definitions
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors combinators combinators.short-circuit
+definitions effects fry hints kernel kernel.private namespaces
+parser quotations see.private sequences words ;
+IN: typed
+
+ERROR: type-mismatch-error word expected-types ;
+ERROR: input-mismatch-error < type-mismatch-error ;
+ERROR: output-mismatch-error < type-mismatch-error ;
+
+! typed inputs
+
+: typed-stack-effect? ( effect -- ? )
+ [ object = ] all? not ;
+
+: input-mismatch-quot ( word types -- quot )
+ [ input-mismatch-error ] 2curry ;
+
+: make-coercer ( types -- quot )
+ [ "coercer" word-prop [ ] or ]
+ [ swap \ dip [ ] 2sequence prepend ]
+ map-reduce ;
+
+: typed-inputs ( quot word types -- quot' )
+ {
+ [ 2nip make-coercer ]
+ [ 2nip make-specializer ]
+ [ nip swap '[ _ declare @ ] ]
+ [ [ drop ] 2dip input-mismatch-quot ]
+ } 3cleave '[ @ @ _ _ if ] ;
+
+! typed outputs
+
+: output-mismatch-quot ( word types -- quot )
+ [ output-mismatch-error ] 2curry ;
+
+: typed-outputs ( quot word types -- quot' )
+ {
+ [ 2drop ]
+ [ 2nip make-coercer ]
+ [ 2nip make-specializer ]
+ [ [ drop ] 2dip output-mismatch-quot ]
+ } 3cleave '[ @ @ @ _ unless ] ;
+
+! defining typed words
+
+: typed-gensym-quot ( def word effect -- quot )
+ [ nip effect-in-types swap '[ _ declare @ ] ]
+ [ effect-out-types dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if ] 2bi ;
+
+: define-typed-gensym ( word def effect -- gensym )
+ [ 3drop gensym dup ]
+ [ [ swap ] dip typed-gensym-quot ]
+ [ 2nip ] 3tri define-declared ;
+
+PREDICATE: typed < word "typed-word" word-prop ;
+
+: typed-quot ( quot word effect -- quot' )
+ [ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
+ [ nip effect-out-types dup typed-stack-effect? [ '[ @ _ declare ] ] [ drop ] if ] 2bi ;
+
+: (typed-def) ( word def effect -- quot )
+ [ define-typed-gensym ] 3keep
+ [ drop [ swap "typed-word" set-word-prop ] [ [ 1quotation ] dip ] 2bi ] dip
+ typed-quot ;
+
+: typed-def ( word def effect -- quot )
+ dup {
+ [ effect-in-types typed-stack-effect? ]
+ [ effect-out-types typed-stack-effect? ]
+ } 1|| [ (typed-def) ] [ drop nip ] if ;
+
+: define-typed ( word def effect -- )
+ [ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-inline ]
+ [ drop "typed-def" set-word-prop ]
+ [ 2drop "typed-word" word-prop \ word set-global ] 3tri ;
+
+SYNTAX: TYPED:
+ (:) define-typed ;
+
+M: typed definer drop \ TYPED: \ ; ;
+M: typed definition "typed-def" word-prop ;
+M: typed declarations. "typed-word" word-prop declarations. ;
+
Teach Vim when to load Factor support files.
ftplugin/factor_settings.vim
Teach Vim to follow the Factor Coding Style guidelines.
+ plugin/factor.vim
+ Teach Vim some commands for navigating Factor source code. See below.
syntax/factor.vim
Syntax highlighting for Factor code.
+The "plugin/factor.vim" file implements the following commands for
+navigating Factor source:
+
+ :FactorVocab factor.vocab.name
+ Opens the source file implementing the "factor.vocab.name"
+ vocabulary.
+ :FactorVocabImpl
+ Opens the main implementation file for the current vocabulary
+ (name.factor). The keyboard shortcut "\fi" is bound to this
+ command.
+ :FactorVocabDocs
+ Opens the documentation file for the current vocabulary
+ (name-docs.factor). The keyboard shortcut "\fd" is bound to this
+ command.
+ :FactorVocabTests
+ Opens the unit test file for the current vocabulary
+ (name-tests.factor). The keyboard shortcut "\ft" is bound to this
+ command.
+
+In order for the ":FactorVocab" command to work, you'll need to set some
+variables in your vimrc file:
+ g:FactorRoot
+ This variable should be set to the root of your Factor
+ installation. The default value is "~/factor".
+ g:FactorVocabRoots
+ This variable should be set to a list of Factor vocabulary roots.
+ The paths may be either relative to g:FactorRoot or absolute paths.
+ The default value is ["core", "basis", "extra", "work"].
+
Note: The syntax-highlighting file is automatically generated to include the
names of all the vocabularies Factor knows about. To regenerate it manually,
run the following code in the listener:
"editors.vim.generate-syntax" run
-...or run it from the command-line:
+...or run it from the command line:
factor -run=editors.vim.generate-syntax
--- /dev/null
+nmap <silent> <Leader>fi :FactorVocabImpl<CR>
+nmap <silent> <Leader>fd :FactorVocabDocs<CR>
+nmap <silent> <Leader>ft :FactorVocabTests<CR>
+
+if !exists("g:FactorRoot")
+ let g:FactorRoot = "~/factor"
+endif
+
+if !exists("g:FactorVocabRoots")
+ let g:FactorVocabRoots = ["core", "basis", "extra", "work"]
+endif
+
+command! -nargs=1 -complete=customlist,FactorCompleteVocab FactorVocab :call GoToFactorVocab("<args>")
+command! FactorVocabImpl :call GoToFactorVocabImpl()
+command! FactorVocabDocs :call GoToFactorVocabDocs()
+command! FactorVocabTests :call GoToFactorVocabTests()
+
+function! FactorVocabRoot(root)
+ let cwd = getcwd()
+ exe "lcd " fnameescape(g:FactorRoot)
+ let vocabroot = fnamemodify(a:root, ":p")
+ exe "lcd " fnameescape(cwd)
+ return vocabroot
+endfunction
+
+function! s:unique(list)
+ let dict = {}
+ for value in a:list
+ let dict[value] = 1
+ endfor
+ return sort(keys(dict))
+endfunction
+
+function! FactorCompleteVocab(arglead, cmdline, cursorpos)
+ let vocabs = []
+ let vocablead = substitute(a:arglead, "\\.", "/", "g")
+ for root in g:FactorVocabRoots
+ let vocabroot = FactorVocabRoot(root)
+ let newvocabs = globpath(vocabroot, vocablead . "*")
+ if newvocabs != ""
+ let newvocabsl = split(newvocabs, "\n")
+ let newvocabsl = filter(newvocabsl, 'getftype(v:val) == "dir"')
+ let newvocabsl = map(newvocabsl, 'substitute(v:val, "^\\V" . escape(vocabroot, "\\"), "\\1", "g")')
+ let vocabs += newvocabsl
+ endif
+ endfor
+ let vocabs = s:unique(vocabs)
+ let vocabs = map(vocabs, 'substitute(v:val, "/\\|\\\\", ".", "g")')
+ return vocabs
+endfunction
+
+function! FactorVocabFile(root, vocab)
+ let vocabpath = substitute(a:vocab, "\\.", "/", "g")
+ let vocabfile = FactorVocabRoot(a:root) . vocabpath . "/" . fnamemodify(vocabpath, ":t") . ".factor"
+
+ if getftype(vocabfile) != ""
+ return vocabfile
+ else
+ return ""
+ endif
+endfunction
+
+function! GoToFactorVocab(vocab)
+ for root in g:FactorVocabRoots
+ let vocabfile = FactorVocabFile(root, a:vocab)
+ if vocabfile != ""
+ exe "edit " fnameescape(vocabfile)
+ return
+ endif
+ endfor
+ echo "Vocabulary " vocab " not found"
+endfunction
+
+function! FactorFileBase()
+ let filename = expand("%:r")
+ let filename = substitute(filename, "-docs", "", "")
+ let filename = substitute(filename, "-tests", "", "")
+ return filename
+endfunction
+
+function! GoToFactorVocabImpl()
+ exe "edit " fnameescape(FactorFileBase() . ".factor")
+endfunction
+
+function! GoToFactorVocabDocs()
+ exe "edit " fnameescape(FactorFileBase() . "-docs.factor")
+endfunction
+
+function! GoToFactorVocabTests()
+ exe "edit " fnameescape(FactorFileBase() . "-tests.factor")
+endfunction
EPILOGUE
mtctr r3
bctr
+
+DEF(void,get_ppc_fpu_env,(void*)):
+ mffs f0
+ stfd f0,0(r3)
+ blr
+
+DEF(void,set_ppc_fpu_env,(const void*)):
+ lfd f0,0(r3)
+ mtfsf 0xff,f0
+ blr
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
add $12,%esp
jmp *%eax
+DEF(void,get_sse_env,(void*)):
+ movl 4(%esp), %eax
+ stmxcsr (%eax)
+ ret
+
+DEF(void,set_sse_env,(const void*)):
+ movl 4(%esp), %eax
+ ldmxcsr (%eax)
+ ret
+
+DEF(void,get_x87_env,(void*)):
+ movl 4(%esp), %eax
+ fnstsw (%eax)
+ fnstcw 2(%eax)
+ ret
+
+DEF(void,set_x87_env,(const void*)):
+ movl 4(%esp), %eax
+ fnclex
+ fldcw 2(%eax)
+ ret
+
#include "cpu-x86.S"
#ifdef WINDOWS
.section .drectve
- .ascii " -export:check_sse2"
.ascii " -export:read_timestamp_counter"
+ .ascii " -export:get_sse_env"
+ .ascii " -export:set_sse_env"
+ .ascii " -export:get_x87_env"
+ .ascii " -export:set_x87_env"
#endif
add $STACK_PADDING,%rsp
jmp *%rax
+DEF(void,get_sse_env,(void*)):
+ stmxcsr (%rdi)
+ ret
+
+DEF(void,set_sse_env,(const void*)):
+ ldmxcsr (%rdi)
+ ret
+
+DEF(void,get_x87_env,(void*)):
+ fnstsw (%rdi)
+ fnstcw 2(%rdi)
+ ret
+
+DEF(void,set_x87_env,(const void*)):
+ fnclex
+ fldcw 2(%rdi)
+ ret
+
#include "cpu-x86.S"
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
static void copy_registered_locals()
{
- cell scan = gc_locals_region->start;
+ std::vector<cell>::const_iterator iter = gc_locals.begin();
+ std::vector<cell>::const_iterator end = gc_locals.end();
- for(; scan <= gc_locals; scan += sizeof(cell))
- copy_handle(*(cell **)scan);
+ for(; iter < end; iter++)
+ copy_handle((cell *)(*iter));
}
static void copy_registered_bignums()
{
- cell scan = gc_bignums_region->start;
+ std::vector<cell>::const_iterator iter = gc_bignums.begin();
+ std::vector<cell>::const_iterator end = gc_bignums.end();
- for(; scan <= gc_bignums; scan += sizeof(cell))
+ for(; iter < end; iter++)
{
- bignum **handle = *(bignum ***)scan;
+ bignum **handle = (bignum **)(*iter);
bignum *pointer = *handle;
if(pointer)
VM_ASM_API void inline_gc(cell *gc_roots_base, cell gc_roots_size)
{
for(cell i = 0; i < gc_roots_size; i++)
- gc_local_push((cell)&gc_roots_base[i]);
+ gc_locals.push_back((cell)&gc_roots_base[i]);
garbage_collection(data->nursery(),false,0);
for(cell i = 0; i < gc_roots_size; i++)
- gc_local_pop();
+ gc_locals.pop_back();
}
}
bool secure_gc_)
{
set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
-
- gc_locals_region = alloc_segment(getpagesize());
- gc_locals = gc_locals_region->start - sizeof(cell);
-
- gc_bignums_region = alloc_segment(getpagesize());
- gc_bignums = gc_bignums_region->start - sizeof(cell);
-
secure_gc = secure_gc_;
-
init_data_gc();
}
gc_off = false;
/* Reset local roots */
- gc_locals = gc_locals_region->start - sizeof(cell);
- gc_bignums = gc_bignums_region->start - sizeof(cell);
+ gc_locals.clear();
+ gc_bignums.clear();
/* If we had an underflow or overflow, stack pointers might be
out of bounds */
general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
}
+void fp_trap_error()
+{
+ general_error(ERROR_FP_TRAP,F,F,NULL);
+}
+
PRIMITIVE(call_clear)
{
throw_impl(dpop(),stack_chain->callstack_bottom);
signal_error(signal_number,signal_callstack_top);
}
+void fp_signal_handler_impl()
+{
+ fp_trap_error();
+}
+
}
ERROR_RS_UNDERFLOW,
ERROR_RS_OVERFLOW,
ERROR_MEMORY,
+ ERROR_FP_TRAP,
};
void out_of_memory();
void signal_error(int signal, stack_frame *native_stack);
void type_error(cell type, cell tagged);
void not_implemented_error();
+void fp_trap_error();
PRIMITIVE(call_clear);
PRIMITIVE(unimplemented);
extern stack_frame *signal_callstack_top;
void memory_signal_handler_impl();
+void fp_signal_handler_impl();
void misc_signal_handler_impl();
}
namespace factor
{
-segment *gc_locals_region;
-cell gc_locals;
+std::vector<cell> gc_locals;
-segment *gc_bignums_region;
-cell gc_bignums;
+std::vector<cell> gc_bignums;
}
/* If a runtime function needs to call another function which potentially
allocates memory, it must wrap any local variable references to Factor
objects in gc_root instances */
-extern segment *gc_locals_region;
-extern cell gc_locals;
-
-DEFPUSHPOP(gc_local_,gc_locals)
+extern std::vector<cell> gc_locals;
template <typename T>
struct gc_root : public tagged<T>
{
- void push() { check_tagged_pointer(tagged<T>::value()); gc_local_push((cell)this); }
+ void push() { check_tagged_pointer(tagged<T>::value()); gc_locals.push_back((cell)this); }
explicit gc_root(cell value_) : tagged<T>(value_) { push(); }
explicit gc_root(T *value_) : tagged<T>(value_) { push(); }
~gc_root() {
#ifdef FACTOR_DEBUG
- cell old = gc_local_pop();
- assert(old == (cell)this);
-#else
- gc_local_pop();
+ assert(gc_locals.back() == (cell)this);
#endif
+ gc_locals.pop_back();
}
};
/* A similar hack for the bignum implementation */
-extern segment *gc_bignums_region;
-extern cell gc_bignums;
-
-DEFPUSHPOP(gc_bignum_,gc_bignums)
+extern std::vector<cell> gc_bignums;
struct gc_bignum
{
gc_bignum(bignum **addr_) : addr(addr_) {
if(*addr_)
check_data_pointer(*addr_);
- gc_bignum_push((cell)addr);
+ gc_bignums.push_back((cell)addr);
}
- ~gc_bignum() { assert((cell)addr == gc_bignum_pop()); }
+ ~gc_bignum() {
+#ifdef FACTOR_DEBUG
+ assert(gc_bignums.back() == (cell)addr);
+#endif
+ gc_bignums.pop_back();
+ }
};
#define GC_BIGNUM(x) gc_bignum x##__gc_root(&x)
/* Modify a suspended thread's thread_state so that when the thread resumes
executing, the call frame of the current C primitive (if any) is rewound, and
the appropriate Factor error is thrown from the top-most Factor frame. */
-static void call_fault_handler(exception_type_t exception,
+static void call_fault_handler(
+ exception_type_t exception,
+ exception_data_type_t code,
MACH_EXC_STATE_TYPE *exc_state,
MACH_THREAD_STATE_TYPE *thread_state)
{
signal_fault_addr = MACH_EXC_STATE_FAULT(exc_state);
MACH_PROGRAM_COUNTER(thread_state) = (cell)memory_signal_handler_impl;
}
- else
- {
- if(exception == EXC_ARITHMETIC)
- signal_number = SIGFPE;
- else
- signal_number = SIGABRT;
+ else if(exception == EXC_ARITHMETIC && code != MACH_EXC_INTEGER_DIV)
+ {
+ MACH_PROGRAM_COUNTER(thread_state) = (cell)fp_signal_handler_impl;
+ }
+ else
+ {
+ signal_number = exception == EXC_ARITHMETIC ? SIGFPE : SIGABRT;
MACH_PROGRAM_COUNTER(thread_state) = (cell)misc_signal_handler_impl;
}
}
/* Modify registers so to have the thread resume executing the
fault handler */
- call_fault_handler(exception,&exc_state,&thread_state);
+ call_fault_handler(exception,code[0],&exc_state,&thread_state);
/* Set the faulting thread's register contents..
#include <time.h>
/* C++ headers */
+#include <vector>
+
#if __GNUC__ == 4
#include <tr1/unordered_map>
#define unordered_map std::tr1::unordered_map
#define MACH_EXC_STATE_TYPE ppc_exception_state_t
#define MACH_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE
#define MACH_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT
+#define MACH_EXC_INTEGER_DIV EXC_PPC_ZERO_DIVIDE
#define MACH_THREAD_STATE_TYPE ppc_thread_state_t
#define MACH_THREAD_STATE_FLAVOR PPC_THREAD_STATE
#define MACH_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT
#define MACH_EXC_STATE_TYPE i386_exception_state_t
#define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE
#define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT
+#define MACH_EXC_INTEGER_DIV EXC_I386_DIV
#define MACH_THREAD_STATE_TYPE i386_thread_state_t
#define MACH_THREAD_STATE_FLAVOR i386_THREAD_STATE
#define MACH_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT
#define MACH_EXC_STATE_TYPE x86_exception_state64_t
#define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64
#define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT
+#define MACH_EXC_INTEGER_DIV EXC_I386_DIV
#define MACH_THREAD_STATE_TYPE x86_thread_state64_t
#define MACH_THREAD_STATE_FLAVOR x86_THREAD_STATE64
#define MACH_THREAD_STATE_COUNT MACHINE_THREAD_STATE_COUNT
UAP_PROGRAM_COUNTER(uap) = (cell)misc_signal_handler_impl;
}
+void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+{
+ signal_number = signal;
+ signal_callstack_top = uap_stack_pointer(uap);
+ UAP_PROGRAM_COUNTER(uap) =
+ (siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF)
+ ? (cell)misc_signal_handler_impl
+ : (cell)fp_signal_handler_impl;
+}
+
static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact)
{
int ret;
{
struct sigaction memory_sigaction;
struct sigaction misc_sigaction;
+ struct sigaction fpe_sigaction;
struct sigaction ignore_sigaction;
memset(&memory_sigaction,0,sizeof(struct sigaction));
sigaction_safe(SIGBUS,&memory_sigaction,NULL);
sigaction_safe(SIGSEGV,&memory_sigaction,NULL);
+ memset(&fpe_sigaction,0,sizeof(struct sigaction));
+ sigemptyset(&fpe_sigaction.sa_mask);
+ fpe_sigaction.sa_sigaction = fpe_signal_handler;
+ fpe_sigaction.sa_flags = SA_SIGINFO;
+
+ sigaction_safe(SIGFPE,&fpe_sigaction,NULL);
+
memset(&misc_sigaction,0,sizeof(struct sigaction));
sigemptyset(&misc_sigaction.sa_mask);
misc_sigaction.sa_sigaction = misc_signal_handler;
misc_sigaction.sa_flags = SA_SIGINFO;
sigaction_safe(SIGABRT,&misc_sigaction,NULL);
- sigaction_safe(SIGFPE,&misc_sigaction,NULL);
sigaction_safe(SIGQUIT,&misc_sigaction,NULL);
sigaction_safe(SIGILL,&misc_sigaction,NULL);
else
signal_callstack_top = NULL;
- if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION)
- {
+ switch (e->ExceptionCode) {
+ case EXCEPTION_ACCESS_VIOLATION:
signal_fault_addr = e->ExceptionInformation[1];
c->EIP = (cell)memory_signal_handler_impl;
- }
+ break;
+
+ case EXCEPTION_FLT_DENORMAL_OPERAND:
+ case EXCEPTION_FLT_DIVIDE_BY_ZERO:
+ case EXCEPTION_FLT_INEXACT_RESULT:
+ case EXCEPTION_FLT_INVALID_OPERATION:
+ case EXCEPTION_FLT_OVERFLOW:
+ case EXCEPTION_FLT_STACK_CHECK:
+ case EXCEPTION_FLT_UNDERFLOW:
+ c->EIP = (cell)fp_signal_handler_impl;
+ break;
+
/* If the Widcomm bluetooth stack is installed, the BTTray.exe process
- injects code into running programs. For some reason this results in
- random SEH exceptions with this (undocumented) exception code being
- raised. The workaround seems to be ignoring this altogether, since that
- is what happens if SEH is not enabled. Don't really have any idea what
- this exception means. */
- else if(e->ExceptionCode != 0x40010006)
- {
+ injects code into running programs. For some reason this results in
+ random SEH exceptions with this (undocumented) exception code being
+ raised. The workaround seems to be ignoring this altogether, since that
+ is what happens if SEH is not enabled. Don't really have any idea what
+ this exception means. */
+ case 0x40010006:
+ break;
+
+ default:
signal_number = e->ExceptionCode;
c->EIP = (cell)misc_signal_handler_impl;
- }
-
- return EXCEPTION_CONTINUE_EXECUTION;
+ break;
+ }
+ return EXCEPTION_CONTINUE_EXECUTION;
}
void c_to_factor_toplevel(cell quot)
projects / factor.git / commitdiff