! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.syntax assocs help.markup
-help.syntax io.backend kernel namespaces ;
+help.syntax io.backend kernel namespaces strings ;
IN: alien.libraries
HELP: <library>
{ $description "A global hashtable that keeps a list of open libraries. Use the " { $link add-library } " word to construct a library and add it with a single call." } ;
HELP: library
-{ $values { "name" "a string" } { "library" assoc } }
+{ $values { "name" string } { "library" assoc } }
{ $description "Looks up a library by its logical name. The library object is a hashtable with the following keys:"
{ $list
{ { $snippet "name" } " - the full path of the C library binary" }
{ $description "Closes a DLL handle created by " { $link dlopen } ". This word might not be implemented on all platforms." } ;
HELP: load-library
-{ $values { "name" "a string" } { "dll" "a DLL handle" } }
+{ $values { "name" string } { "dll" "a DLL handle" } }
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
HELP: add-library
-{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
+{ $values { "name" string } { "path" string } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }
{ $description "Defines a new logical library named " { $snippet "name" } " located in the file system at " { $snippet "path" } "and the specified ABI." }
{ $notes "Because the entire source file is parsed before top-level forms are executed, " { $link add-library } " cannot be used in the same file as " { $link POSTPONE: FUNCTION: } " definitions from that library. The " { $link add-library } " call will happen too late, after compilation, and the alien calls will not work."
$nl
}
"Note the parse time evaluation with " { $link POSTPONE: << } "." } ;
+HELP: remove-library
+{ $values { "name" string } }
+{ $description "Unloads a library and removes it from the internal list of libraries. The " { $snippet "name" } " parameter should be a name that was previously passed to " { $link add-library } ". If no library with that name exists, this word does nothing." } ;
+
ARTICLE: "loading-libs" "Loading native libraries"
"Before calling a C library, you must associate its path name on disk with a logical name which Factor uses to identify the library:"
{ $subsection add-library }
+{ $subsection remove-library }
"Once a library has been defined, you can try loading it to see if the path name is correct:"
{ $subsection load-library }
"If the compiler cannot load a library, or cannot resolve a symbol in a library, a linkage error is reported using the compiler error mechanism (see " { $link "compiler-errors" } "). Once you install the right library, reload the source file containing the " { $link add-library } " form to force the compiler to try loading the library again." ;
--- /dev/null
+IN: alien.libraries.tests
+USING: alien.libraries alien.syntax tools.test kernel ;
+
+[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
+
+[ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test
+
+[ ] [ "doesnotexist" dlopen dlclose ] unit-test
+
+[ "fdasfsf" dll-valid? drop ] must-fail
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.strings assocs io.backend kernel namespaces ;
+USING: accessors alien alien.strings assocs io.backend
+kernel namespaces destructors ;
IN: alien.libraries
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
: load-library ( name -- dll )
library dup [ dll>> ] when ;
-: add-library ( name path abi -- )
- <library> swap libraries get set-at ;
\ No newline at end of file
+M: dll dispose dlclose ;
+
+M: library dispose dll>> [ dispose ] when* ;
+
+: remove-library ( name -- )
+ libraries get delete-at* [ dispose ] [ drop ] if ;
+
+: add-library ( name path abi -- )
+ <library> swap libraries get [ delete-at ] [ set-at ] 2bi ;
\ No newline at end of file
}
"C structure objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
$nl
-"Arrays of C structures can be created by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-STRUCT: } "." ;
+"Arrays of C structures can be created with the " { $vocab-link "struct-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 by calling " { $link <c-array> } " or " { $link malloc-array } ". Elements can be read and written using words named " { $snippet { $emphasis "type" } "-nth" } " and " { $snippet "set-" { $emphasis "type" } "-nth" } "; these words are automatically generated by " { $link POSTPONE: C-UNION: } "." ;
+"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
\ No newline at end of file
[ byte/bit set-bit ] 2keep
swap n>byte set-alien-unsigned-1 ;
-: clear-bits ( bit-array -- ) 0 (set-bits) ;
+GENERIC: clear-bits ( bit-array -- )
-: set-bits ( bit-array -- ) -1 (set-bits) ;
+M: bit-array clear-bits 0 (set-bits) ;
+
+GENERIC: set-bits ( bit-array -- )
+
+M: bit-array set-bits -1 (set-bits) ;
M: bit-array clone
[ length>> ] [ underlying>> clone ] bi bit-array boa ;
--- /dev/null
+Slava Pestov
--- /dev/null
+IN: bit-sets.tests
+USING: bit-sets tools.test bit-arrays ;
+
+[ ?{ t f t f t f } ] [
+ ?{ t f f f t f }
+ ?{ f f t f t f } bit-set-union
+] unit-test
+
+[ ?{ f f f f t f } ] [
+ ?{ t f f f t f }
+ ?{ f f t f t f } bit-set-intersect
+] unit-test
+
+[ ?{ t f t f f f } ] [
+ ?{ t t t f f f }
+ ?{ f t f f t t } bit-set-diff
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences byte-arrays bit-arrays math hints ;
+IN: bit-sets
+
+<PRIVATE
+
+: bit-set-map ( seq1 seq2 quot -- seq )
+ [ 2drop length>> ]
+ [
+ [
+ [ [ length ] bi@ assert= ]
+ [ [ underlying>> ] bi@ ] 2bi
+ ] dip 2map
+ ] 3bi bit-array boa ; inline
+
+PRIVATE>
+
+: bit-set-union ( seq1 seq2 -- seq ) [ bitor ] bit-set-map ;
+
+HINTS: bit-set-union bit-array bit-array ;
+
+: bit-set-intersect ( seq1 seq2 -- seq ) [ bitand ] bit-set-map ;
+
+HINTS: bit-set-intersect bit-array bit-array ;
+
+: bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ;
+
+HINTS: bit-set-diff bit-array bit-array ;
\ No newline at end of file
--- /dev/null
+Efficient bitwise operations on bit arrays
{ $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;\r
\r
HELP: <bit-vector>\r
-{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }\r
+{ $values { "capacity" "a positive integer specifying initial capacity" } { "vector" bit-vector } }\r
{ $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;\r
\r
HELP: >bit-vector\r
-{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } }\r
+{ $values { "seq" "a sequence" } { "vector" bit-vector } }\r
{ $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;\r
\r
HELP: ?V{\r
-! Copyright (C) 2008 Slava Pestov.\r
+! Copyright (C) 2008, 2009 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
USING: arrays kernel kernel.private math sequences\r
sequences.private growable bit-arrays prettyprint.custom\r
-parser accessors ;\r
+parser accessors vectors.functor classes.parser ;\r
IN: bit-vectors\r
\r
-TUPLE: bit-vector\r
-{ underlying bit-array initial: ?{ } }\r
-{ length array-capacity } ;\r
-\r
-: <bit-vector> ( n -- bit-vector )\r
- <bit-array> 0 bit-vector boa ; inline\r
-\r
-: >bit-vector ( seq -- bit-vector )\r
- T{ bit-vector f ?{ } 0 } clone-like ;\r
-\r
-M: bit-vector like\r
- drop dup bit-vector? [\r
- dup bit-array?\r
- [ dup length bit-vector boa ] [ >bit-vector ] if\r
- ] unless ;\r
-\r
-M: bit-vector new-sequence\r
- drop [ <bit-array> ] [ >fixnum ] bi bit-vector boa ;\r
-\r
-M: bit-vector equal?\r
- over bit-vector? [ sequence= ] [ 2drop f ] if ;\r
-\r
-M: bit-array new-resizable drop <bit-vector> ;\r
-\r
-INSTANCE: bit-vector growable\r
+<< "bit-vector" create-class-in \ bit-array \ <bit-array> define-vector >>\r
\r
SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;\r
\r
+M: bit-vector contract 2drop ;\r
M: bit-vector >pprint-sequence ;\r
M: bit-vector pprint-delims drop \ ?V{ \ } ;\r
M: bit-vector pprint* pprint-object ;\r
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel splitting grouping math sequences namespaces make
-io.binary math.bitwise checksums checksums.common
-sbufs strings combinators.smart math.ranges fry combinators
-accessors locals checksums.stream multiline literals
-generalizations ;
+USING: accessors checksums checksums.common checksums.stream
+combinators combinators.smart fry generalizations grouping
+io.binary kernel literals locals make math math.bitwise
+math.ranges multiline namespaces sbufs sequences
+sequences.private splitting strings ;
IN: checksums.sha
SINGLETON: sha1
: prepare-M-256 ( n seq -- )
{
- [ [ 16 - ] dip nth ]
- [ [ 15 - ] dip nth s0-256 ]
- [ [ 7 - ] dip nth ]
- [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+ [ [ 16 - ] dip nth-unsafe ]
+ [ [ 15 - ] dip nth-unsafe s0-256 ]
+ [ [ 7 - ] dip nth-unsafe ]
+ [ [ 2 - ] dip nth-unsafe s1-256 w+ w+ w+ ]
[ ]
- } 2cleave set-nth ; inline
+ } 2cleave set-nth-unsafe ; inline
: prepare-M-512 ( n seq -- )
{
- [ [ 16 - ] dip nth ]
- [ [ 15 - ] dip nth s0-512 ]
- [ [ 7 - ] dip nth ]
- [ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
+ [ [ 16 - ] dip nth-unsafe ]
+ [ [ 15 - ] dip nth-unsafe s0-512 ]
+ [ [ 7 - ] dip nth-unsafe ]
+ [ [ 2 - ] dip nth-unsafe s1-512 w+ w+ w+ ]
[ ]
- } 2cleave set-nth ; inline
+ } 2cleave set-nth-unsafe ; inline
: ch ( x y z -- x' )
[ bitxor bitand ] keep bitxor ; inline
GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
:: T1-256 ( n M H sha2 -- T1 )
- n M nth
- n sha2 K>> nth +
+ n M nth-unsafe
+ n sha2 K>> nth-unsafe +
e H slice3 ch w+
- e H nth S1-256 w+
- h H nth w+ ; inline
+ e H nth-unsafe S1-256 w+
+ h H nth-unsafe w+ ; inline
: T2-256 ( H -- T2 )
- [ a swap nth S0-256 ]
+ [ a swap nth-unsafe S0-256 ]
[ a swap slice3 maj w+ ] bi ; inline
:: T1-512 ( n M H sha2 -- T1 )
- n M nth
- n sha2 K>> nth +
+ n M nth-unsafe
+ n sha2 K>> nth-unsafe +
e H slice3 ch w+
- e H nth S1-512 w+
- h H nth w+ ; inline
+ e H nth-unsafe S1-512 w+
+ h H nth-unsafe w+ ; inline
: T2-512 ( H -- T2 )
- [ a swap nth S0-512 ]
+ [ a swap nth-unsafe S0-512 ]
[ a swap slice3 maj w+ ] bi ; inline
: update-H ( T1 T2 H -- )
- h g pick exchange
- g f pick exchange
- f e pick exchange
- pick d pick nth w+ e pick set-nth
- d c pick exchange
- c b pick exchange
- b a pick exchange
- [ w+ a ] dip set-nth ; inline
+ h g pick exchange-unsafe
+ g f pick exchange-unsafe
+ f e pick exchange-unsafe
+ pick d pick nth-unsafe w+ e pick set-nth-unsafe
+ d c pick exchange-unsafe
+ c b pick exchange-unsafe
+ b a pick exchange-unsafe
+ [ w+ a ] dip set-nth-unsafe ; inline
: prepare-message-schedule ( seq sha2 -- w-seq )
[ word-size>> <sliced-groups> [ be> ] map ]
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
: seq>byte-array ( seq n -- string )
- '[ _ >be ] map B{ } join ;
+ '[ _ >be ] map B{ } concat-as ;
: sha1>checksum ( sha2 -- bytes )
H>> 4 seq>byte-array ;
drop
[ <sha-256-state> ] dip add-checksum-stream get-checksum ;
-
-
: sha1-W ( t seq -- )
{
- [ [ 3 - ] dip nth ]
- [ [ 8 - ] dip nth bitxor ]
- [ [ 14 - ] dip nth bitxor ]
- [ [ 16 - ] dip nth bitxor 1 bitroll-32 ]
+ [ [ 3 - ] dip nth-unsafe ]
+ [ [ 8 - ] dip nth-unsafe bitxor ]
+ [ [ 14 - ] dip nth-unsafe bitxor ]
+ [ [ 16 - ] dip nth-unsafe bitxor 1 bitroll-32 ]
[ ]
- } 2cleave set-nth ;
+ } 2cleave set-nth-unsafe ;
: prepare-sha1-message-schedule ( seq -- w-seq )
4 <sliced-groups> [ be> ] map
} case ;
:: inner-loop ( n H W K -- temp )
- a H nth :> A
- b H nth :> B
- c H nth :> C
- d H nth :> D
- e H nth :> E
+ a H nth-unsafe :> A
+ b H nth-unsafe :> B
+ c H nth-unsafe :> C
+ d H nth-unsafe :> D
+ e H nth-unsafe :> E
[
A 5 bitroll-32
E
- n K nth
+ n K nth-unsafe
- n W nth
+ n W nth-unsafe
] sum-outputs 32 bits ;
:: process-sha1-chunk ( bytes H W K state -- )
80 [
H W K inner-loop
- d H nth e H set-nth
- c H nth d H set-nth
- b H nth 30 bitroll-32 c H set-nth
- a H nth b H set-nth
- a H set-nth
+ d H nth-unsafe e H set-nth-unsafe
+ c H nth-unsafe d H set-nth-unsafe
+ b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe
+ a H nth-unsafe b H set-nth-unsafe
+ a H set-nth-unsafe
] each
state [ H [ w+ ] 2map ] change-H drop ; inline
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax io.streams.string quotations
-math ;
+math kernel ;
IN: combinators.short-circuit
HELP: 0&&
-{ $values
- { "quots" "a sequence of quotations" }
- { "quot" quotation } }
-{ $description "Returns true if every quotation in the sequence of quotations returns true." } ;
+{ $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" }
- { "quot" quotation } }
-{ $description "Returns true if any quotation in the sequence returns true." } ;
+{ $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
- { "quots" "a sequence of quotations" }
- { "quot" quotation } }
-{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same element from the datastack and must output a boolean." } ;
+{ $values { "obj" object } { "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: 1||
-{ $values
- { "quots" "a sequence of quotations" }
- { "quot" quotation } }
+{ $values { "obj" object } { "quots" "a sequence of quotations" } { "?" "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
- { "quots" "a sequence of quotations" }
- { "quot" quotation } }
-{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same two elements from the datastack and must output a boolean." } ;
+{ $values { "obj1" object } { "obj2" object } { "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: 2||
-{ $values
- { "quots" "a sequence of quotations" }
- { "quot" quotation } }
+{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations" } { "?" "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
- { "quots" "a sequence of quotations" }
- { "quot" quotation } }
-{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same three elements from the datastack and must output a boolean." } ;
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "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: 3||
-{ $values
- { "quots" "a sequence of quotations" }
- { "quot" quotation } }
+{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations" } { "?" "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&&
{ $values
- { "quots" "a sequence of quotations" } { "N" integer }
+ { "quots" "a sequence of quotations" } { "n" integer }
{ "quot" quotation } }
-{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ;
+{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each quotation, evaluating the result in the same manner as " { $link 0&& } "." } ;
HELP: n||
{ $values
-
USING: kernel math tools.test combinators.short-circuit ;
-
IN: combinators.short-circuit.tests
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-: must-be-t ( in -- ) [ t ] swap unit-test ;
-: must-be-f ( in -- ) [ f ] swap unit-test ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-[ { [ 1 ] [ 2 ] [ 3 ] } 0&& 3 = ] must-be-t
-[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& 5 = ] must-be-t
-[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& 30 = ] must-be-t
-
-[ { [ 1 ] [ f ] [ 3 ] } 0&& 3 = ] must-be-f
-[ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] must-be-f
-[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& 30 = ] must-be-f
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+[ 3 ] [ { [ 1 ] [ 2 ] [ 3 ] } 0&& ] unit-test
+[ 5 ] [ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& ] unit-test
+[ 30 ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& ] unit-test
-[ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| "factor" = ] must-be-t
+[ f ] [ { [ 1 ] [ f ] [ 3 ] } 0&& ] unit-test
+[ f ] [ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] unit-test
+[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& ] unit-test
-[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| 11 = ] must-be-t
+[ "factor" ] [ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| ] unit-test
+[ 11 ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| ] unit-test
+[ 30 ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| ] unit-test
+[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] unit-test
-[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| 30 = ] must-be-t
+: compiled-&& ( a -- ? ) { [ 0 > ] [ even? ] [ 2 + ] } 1&& ;
-[ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] must-be-f
+[ f ] [ 3 compiled-&& ] unit-test
+[ 4 ] [ 2 compiled-&& ] unit-test
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: compiled-|| ( a b -- ? ) { [ + odd? ] [ + 100 > ] [ + ] } 2|| ;
+[ 30 ] [ 10 20 compiled-|| ] unit-test
+[ 2 ] [ 1 1 compiled-|| ] unit-test
\ No newline at end of file
n '[ _ nnip ] suffix 1array
[ cond ] 3append ;
-MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
-MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ;
-MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
-MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
+<PRIVATE
+
+: unoptimized-&& ( quots quot -- ? )
+ [ [ call dup ] ] dip call [ nip ] prepose [ f ] 2dip all? swap and ; inline
+
+PRIVATE>
+
+: 0&& ( quots -- ? ) [ ] unoptimized-&& ;
+: 1&& ( obj quots -- ? ) [ with ] unoptimized-&& ;
+: 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 '[ drop _ ndrop t ] [ f ] 2array suffix 1array
[ cond ] 3append ;
-MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;
-MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ;
-MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ;
-MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ;
+<PRIVATE
+
+: unoptimized-|| ( quots quot -- ? )
+ [ [ call ] ] dip call map-find drop ; inline
+
+PRIVATE>
+
+: 0|| ( quots -- ? ) [ ] unoptimized-|| ;
+: 1|| ( obj quots -- ? ) [ with ] unoptimized-|| ;
+: 2|| ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-|| ;
+: 3|| ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-|| ;
USING: kernel math namespaces assocs hashtables sequences arrays
accessors vectors combinators sets classes compiler.cfg
compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.copy-prop compiler.cfg.rpo
-compiler.cfg.liveness compiler.cfg.local ;
+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.
M: ##set-slot-imm insn-object obj>> resolve ;
M: ##alien-global insn-object drop \ ##alien-global ;
-: init-alias-analysis ( live-in -- )
+: init-alias-analysis ( insns -- insns' )
H{ } clone histories set
H{ } clone vregs>acs set
H{ } clone acs>vregs set
0 ac-counter set
next-ac heap-ac set
- [ set-heap-ac ] each ;
+ dup local-live-in [ set-heap-ac ] each ;
GENERIC: analyze-aliases* ( insn -- insn' )
[ insn# set eliminate-dead-stores* ] map-index sift ;
: alias-analysis-step ( insns -- insns' )
+ init-alias-analysis
analyze-aliases
compute-live-stores
eliminate-dead-stores ;
: alias-analysis ( cfg -- cfg' )
- [ init-alias-analysis ] [ alias-analysis-step ] local-optimization ;
\ No newline at end of file
+ [ alias-analysis-step ] local-optimization ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit kernel sequences math
+compiler.utilities compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.utilities ;
+IN: compiler.cfg.block-joining
+
+! Joining blocks that are not calls and are connected by a single CFG edge.
+! Predecessors must be recomputed after this. Also this pass does not
+! update ##phi nodes and should therefore only run before stack analysis.
+
+: kill-vreg-block? ( bb -- ? )
+ instructions>> {
+ [ length 2 >= ]
+ [ penultimate kill-vreg-insn? ]
+ } 1&& ;
+
+: predecessor ( bb -- pred )
+ predecessors>> first ; inline
+
+: join-block? ( bb -- ? )
+ {
+ [ predecessors>> length 1 = ]
+ [ predecessor kill-vreg-block? not ]
+ [ predecessor successors>> length 1 = ]
+ [ [ predecessor ] keep back-edge? not ]
+ } 1&& ;
+
+: join-instructions ( bb pred -- )
+ [ instructions>> ] bi@ dup pop* push-all ;
+
+: update-successors ( bb pred -- )
+ [ successors>> ] dip (>>successors) ;
+
+: join-block ( bb pred -- )
+ [ join-instructions ] [ update-successors ] 2bi ;
+
+: join-blocks ( cfg -- cfg' )
+ dup post-order [
+ dup join-block?
+ [ dup predecessor join-block ] [ drop ] if
+ ] each
+ cfg-changed ;
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+USING: accessors assocs compiler.cfg
+compiler.cfg.branch-splitting compiler.cfg.debugger
+compiler.cfg.predecessors compiler.cfg.rpo compiler.cfg.instructions fry kernel
+tools.test namespaces sequences vectors ;
+IN: compiler.cfg.branch-splitting.tests
+
+: get-predecessors ( cfg -- assoc )
+ H{ } clone [ '[ [ predecessors>> ] keep _ set-at ] each-basic-block ] keep ;
+
+: check-predecessors ( cfg -- )
+ [ get-predecessors ]
+ [ compute-predecessors drop ]
+ [ get-predecessors ] tri assert= ;
+
+: check-branch-splitting ( cfg -- )
+ compute-predecessors
+ split-branches
+ check-predecessors ;
+
+: test-branch-splitting ( -- )
+ cfg new 0 get >>entry check-branch-splitting ;
+
+V{ T{ ##branch } } 0 test-bb
+
+V{ T{ ##branch } } 1 test-bb
+
+V{ T{ ##branch } } 2 test-bb
+
+V{ T{ ##branch } } 3 test-bb
+
+V{ T{ ##branch } } 4 test-bb
+
+test-diamond
+
+[ ] [ test-branch-splitting ] unit-test
+
+V{ T{ ##branch } } 0 test-bb
+
+V{ T{ ##branch } } 1 test-bb
+
+V{ T{ ##branch } } 2 test-bb
+
+V{ T{ ##branch } } 3 test-bb
+
+V{ T{ ##branch } } 4 test-bb
+
+V{ T{ ##branch } } 5 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+
+1 get 3 get 4 get V{ } 2sequence >>successors drop
+
+2 get 3 get 4 get V{ } 2sequence >>successors drop
+
+[ ] [ test-branch-splitting ] unit-test
+
+V{ T{ ##branch } } 0 test-bb
+
+V{ T{ ##branch } } 1 test-bb
+
+V{ T{ ##branch } } 2 test-bb
+
+V{ T{ ##branch } } 3 test-bb
+
+V{ T{ ##branch } } 4 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+
+1 get 3 get 4 get V{ } 2sequence >>successors drop
+
+2 get 4 get 1vector >>successors drop
+
+[ ] [ test-branch-splitting ] unit-test
+
+V{ T{ ##branch } } 0 test-bb
+
+V{ T{ ##branch } } 1 test-bb
+
+V{ T{ ##branch } } 2 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+
+1 get 2 get 1vector >>successors drop
+
+[ ] [ test-branch-splitting ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit kernel math math.order
+sequences assocs namespaces vectors fry arrays splitting
+compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
+compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
+IN: compiler.cfg.branch-splitting
+
+: clone-renamings ( insns -- assoc )
+ [ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ;
+
+: clone-instructions ( insns -- insns' )
+ dup clone-renamings renamings [
+ [
+ clone
+ dup rename-insn-defs
+ dup rename-insn-uses
+ dup fresh-insn-temps
+ ] map
+ ] with-variable ;
+
+: clone-basic-block ( bb -- bb' )
+ ! The new block gets the same RPO number as the old one.
+ ! This is just to make 'back-edge?' work.
+ <basic-block>
+ swap
+ [ instructions>> clone-instructions >>instructions ]
+ [ successors>> clone >>successors ]
+ [ number>> >>number ]
+ tri ;
+
+: new-blocks ( bb -- copies )
+ dup predecessors>> [
+ [ clone-basic-block ] dip
+ 1vector >>predecessors
+ ] with map ;
+
+: update-predecessor-successor ( pred copy old-bb -- )
+ '[
+ [ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map
+ ] change-successors drop ;
+
+: update-predecessor-successors ( copies old-bb -- )
+ [ predecessors>> swap ] keep
+ '[ _ update-predecessor-successor ] 2each ;
+
+: update-successor-predecessor ( copies old-bb succ -- )
+ [
+ swap 1array split swap join V{ } like
+ ] change-predecessors drop ;
+
+: update-successor-predecessors ( copies old-bb -- )
+ dup successors>> [
+ update-successor-predecessor
+ ] with with each ;
+
+: split-branch ( bb -- )
+ [ new-blocks ] keep
+ [ update-predecessor-successors ]
+ [ update-successor-predecessors ]
+ 2bi ;
+
+UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
+
+: split-instructions? ( insns -- ? )
+ [ [ irrelevant? not ] count 5 <= ]
+ [ last ##fixnum-overflow? not ]
+ bi and ;
+
+: split-branch? ( bb -- ? )
+ {
+ [ dup successors>> [ back-edge? ] with any? not ]
+ [ predecessors>> length 2 4 between? ]
+ [ instructions>> split-instructions? ]
+ } 1&& ;
+
+: split-branches ( cfg -- cfg' )
+ dup [
+ dup split-branch? [ split-branch ] [ drop ] if
+ ] each-basic-block
+ cfg-changed ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces accessors math.order assocs kernel sequences
combinators make classes words cpu.architecture
] when ;
\ _spill t frame-required? set-word-prop
-\ ##fixnum-add t frame-required? set-word-prop
-\ ##fixnum-sub t frame-required? set-word-prop
-\ ##fixnum-mul t frame-required? set-word-prop
-\ ##fixnum-add-tail f frame-required? set-word-prop
-\ ##fixnum-sub-tail f frame-required? set-word-prop
-\ ##fixnum-mul-tail f frame-required? set-word-prop
: compute-stack-frame ( insns -- )
frame-required? off
[ 3 fixnum+fast ]
[ fixnum*fast ]
[ 3 fixnum*fast ]
+ [ 3 swap fixnum*fast ]
[ fixnum-shift-fast ]
[ 10 fixnum-shift-fast ]
[ -10 fixnum-shift-fast ]
[ 0 fixnum-shift-fast ]
+ [ 10 swap fixnum-shift-fast ]
+ [ -10 swap fixnum-shift-fast ]
+ [ 0 swap fixnum-shift-fast ]
[ fixnum-bitnot ]
[ eq? ]
[ "hi" eq? ]
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators hashtables kernel
math fry namespaces make sequences words byte-arrays
compiler.cfg
compiler.cfg.hats
compiler.cfg.stacks
-compiler.cfg.iterator
compiler.cfg.utilities
compiler.cfg.registers
compiler.cfg.intrinsics
+compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.cfg.instructions
compiler.alien ;
! Convert tree SSA IR to CFG SSA IR.
SYMBOL: procedures
-SYMBOL: current-word
-SYMBOL: current-label
SYMBOL: loops
-SYMBOL: first-basic-block
-
-! Basic block after prologue, makes recursion faster
-SYMBOL: current-label-start
-
-: add-procedure ( -- )
- basic-block get current-word get current-label get
- <cfg> procedures get push ;
: begin-procedure ( word label -- )
end-basic-block
begin-basic-block
H{ } clone loops set
- current-label set
- current-word set
- add-procedure ;
+ [ basic-block get ] 2dip
+ <cfg> procedures get push ;
: with-cfg-builder ( nodes word label quot -- )
'[ begin-procedure @ ] with-scope ; inline
-GENERIC: emit-node ( node -- next )
-
-: check-basic-block ( node -- node' )
- basic-block get [ drop f ] unless ; inline
+GENERIC: emit-node ( node -- )
: emit-nodes ( nodes -- )
- [ current-node emit-node check-basic-block ] iterate-nodes ;
+ [ basic-block get [ emit-node ] [ drop ] if ] each ;
: begin-word ( -- )
- #! We store the basic block after the prologue as a loop
- #! labeled by the current word, so that self-recursive
- #! calls can skip an epilogue/prologue.
##prologue
##branch
- begin-basic-block
- basic-block get first-basic-block set ;
+ begin-basic-block ;
: (build-cfg) ( nodes word label -- )
[
begin-word
- V{ } clone node-stack set
emit-nodes
] with-cfg-builder ;
] with-variable
] keep ;
-: local-recursive-call ( basic-block -- next )
+: emit-loop-call ( basic-block -- )
##branch
basic-block get successors>> push
- stop-iterating ;
+ basic-block off ;
-: emit-call ( word height -- next )
- {
- { [ over loops get key? ] [ drop loops get at local-recursive-call ] }
- { [ terminate-call? ] [ ##call stop-iterating ] }
- { [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
- { [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] }
- [ drop ##epilogue ##jump stop-iterating ]
- } cond ;
+: emit-call ( word -- )
+ dup loops get key?
+ [ loops get at emit-loop-call ]
+ [ ##call ##branch begin-basic-block ]
+ if ;
! #recursive
-: recursive-height ( #recursive -- n )
- [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
-
-: emit-recursive ( #recursive -- next )
- [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
+: emit-recursive ( #recursive -- )
+ [ label>> id>> emit-call ]
[ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
: remember-loop ( label -- )
basic-block get swap loops get set-at ;
-: emit-loop ( node -- next )
+: emit-loop ( node -- )
##loop-entry
##branch
begin-basic-block
- [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
- iterate-next ;
+ [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
M: #recursive emit-node
dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
! #if
: emit-branch ( obj -- final-bb )
- [
- begin-basic-block
- emit-nodes
- basic-block get dup [ ##branch ] when
- ] with-scope ;
+ [ emit-nodes ] with-branch ;
: emit-if ( node -- )
- children>> [ emit-branch ] map
- end-basic-block
- begin-basic-block
- basic-block get '[ [ _ swap successors>> push ] when* ] each ;
+ children>> [ emit-branch ] map emit-conditional ;
: ##branch-t ( vreg -- )
\ f tag-number cc/= ##compare-imm-branch ;
{ [ dup trivial-if? ] [ drop emit-trivial-if ] }
{ [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
[ ds-pop ##branch-t emit-if ]
- } cond iterate-next ;
+ } cond ;
! #dispatch
M: #dispatch emit-node
- ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
+ ds-pop ^^offset>slot i ##dispatch emit-if ;
! #call
M: #call emit-node
dup word>> dup "intrinsic" word-prop
- [ emit-intrinsic ] [ swap call-height emit-call ] if ;
+ [ emit-intrinsic ] [ nip emit-call ] if ;
! #call-recursive
-M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
+M: #call-recursive emit-node label>> id>> emit-call ;
! #push
M: #push emit-node
- literal>> ^^load-literal ds-push iterate-next ;
+ literal>> ^^load-literal ds-push ;
! #shuffle
M: #shuffle emit-node
[ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
[ nip ] 2tri
[ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
- [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi
- iterate-next ;
+ [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
! #return
M: #return emit-node
- drop ##epilogue ##return stop-iterating ;
+ drop ##epilogue ##return ;
M: #return-recursive emit-node
label>> id>> loops get key?
- [ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
+ [ ##epilogue ##return ] unless ;
! #terminate
-M: #terminate emit-node drop stop-iterating ;
+M: #terminate emit-node drop ##no-tco basic-block off ;
! FFI
: return-size ( ctype -- n )
: alien-stack-frame ( params -- )
<alien-stack-frame> ##stack-frame ;
-: emit-alien-node ( node quot -- next )
+: emit-alien-node ( node quot -- )
[ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
- ##branch begin-basic-block iterate-next ; inline
+ ##branch begin-basic-block ; inline
M: #alien-invoke emit-node
[ ##alien-invoke ] emit-alien-node ;
dup params>> xt>> dup
[
##prologue
- dup [ ##alien-callback ] emit-alien-node drop
+ dup [ ##alien-callback ] emit-alien-node
##epilogue
params>> ##callback-return
- ] with-cfg-builder
- iterate-next ;
+ ] with-cfg-builder ;
! No-op nodes
-M: #introduce emit-node drop iterate-next ;
+M: #introduce emit-node drop ;
-M: #copy emit-node drop iterate-next ;
+M: #copy emit-node drop ;
-M: #enter-recursive emit-node drop iterate-next ;
+M: #enter-recursive emit-node drop ;
-M: #phi emit-node drop iterate-next ;
+M: #phi emit-node drop ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays vectors accessors
-namespaces math make fry sequences ;
+USING: kernel math vectors arrays accessors namespaces ;
IN: compiler.cfg
TUPLE: basic-block < identity-tuple
V{ } clone >>predecessors
\ basic-block counter >>id ;
-: add-instructions ( bb quot -- )
- [ instructions>> building ] dip '[
- building get pop
- _ dip
- building get push
- ] with-variable ; inline
-
TUPLE: cfg { entry basic-block } word label spill-counts post-order ;
: <cfg> ( entry word label -- cfg ) f f cfg boa ;
+: cfg-changed ( cfg -- cfg ) f >>post-order ; inline
+
TUPLE: mr { instructions array } word label ;
: <mr> ( instructions word label -- mr )
! 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.liveness
+compiler.cfg.def-use compiler.cfg.linearization
combinators.short-circuit accessors math sequences sets assocs ;
IN: compiler.cfg.checker
[ ##return? ]
[ ##callback-return? ]
[ ##jump? ]
- [ ##fixnum-add-tail? ]
- [ ##fixnum-sub-tail? ]
- [ ##fixnum-mul-tail? ]
- [ ##call? ]
+ [ ##fixnum-add? ]
+ [ ##fixnum-sub? ]
+ [ ##fixnum-mul? ]
+ [ ##no-tco? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
ERROR: bad-loop-entry ;
2dup subset? [ 2drop ] [ undefined-values ] if ;
: check-cfg ( cfg -- )
- compute-liveness
- [ entry>> live-in assoc-empty? [ bad-live-in ] unless ]
[ [ check-basic-block ] each-basic-block ]
[ flatten-cfg check-mr ]
- tri ;
+ bi ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs math.order sequences ;
+IN: compiler.cfg.comparisons
+
+SYMBOLS: cc< cc<= cc= cc> cc>= cc/= ;
+
+: negate-cc ( cc -- cc' )
+ H{
+ { cc< cc>= }
+ { cc<= cc> }
+ { cc> cc<= }
+ { cc>= cc< }
+ { cc= cc/= }
+ { cc/= cc= }
+ } at ;
+
+: swap-cc ( cc -- cc' )
+ H{
+ { cc< cc> }
+ { cc<= cc>= }
+ { cc> cc< }
+ { cc>= cc<= }
+ { cc= cc= }
+ { cc/= cc/= }
+ } at ;
+
+: evaluate-cc ( result cc -- ? )
+ H{
+ { cc< { +lt+ } }
+ { cc<= { +lt+ +eq+ } }
+ { cc= { +eq+ } }
+ { cc>= { +eq+ +gt+ } }
+ { cc> { +gt+ } }
+ { cc/= { +lt+ +gt+ } }
+ } at memq? ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs deques dlists kernel locals sequences lexer
+namespaces functors compiler.cfg.rpo compiler.cfg.utilities
+compiler.cfg ;
+IN: compiler.cfg.dataflow-analysis
+
+GENERIC: join-sets ( sets dfa -- set )
+GENERIC: transfer-set ( in-set bb dfa -- out-set )
+GENERIC: block-order ( cfg dfa -- bbs )
+GENERIC: successors ( bb dfa -- seq )
+GENERIC: predecessors ( bb dfa -- seq )
+
+<PRIVATE
+
+MIXIN: dataflow-analysis
+
+: <dfa-worklist> ( cfg dfa -- queue )
+ block-order <hashed-dlist> [ push-all-front ] keep ;
+
+GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
+
+! M: kill-block compute-in-set 3drop f ;
+
+M:: basic-block compute-in-set ( bb out-sets dfa -- set )
+ bb dfa predecessors [ out-sets at ] map dfa join-sets ;
+
+:: update-in-set ( bb in-sets out-sets dfa -- ? )
+ bb out-sets dfa compute-in-set
+ bb in-sets maybe-set-at ; inline
+
+GENERIC# compute-out-set 2 ( bb out-sets dfa -- set )
+
+! M: kill-block compute-out-set 3drop f ;
+
+M:: basic-block compute-out-set ( bb in-sets dfa -- set )
+ bb in-sets at bb dfa transfer-set ;
+
+:: update-out-set ( bb in-sets out-sets dfa -- ? )
+ bb in-sets dfa compute-out-set
+ bb out-sets maybe-set-at ; inline
+
+:: dfa-step ( bb in-sets out-sets dfa work-list -- )
+ bb in-sets out-sets dfa update-in-set [
+ bb in-sets out-sets dfa update-out-set [
+ bb dfa successors work-list push-all-front
+ ] when
+ ] when ; inline
+
+:: run-dataflow-analysis ( cfg dfa -- in-sets out-sets )
+ H{ } clone :> in-sets
+ H{ } clone :> out-sets
+ cfg dfa <dfa-worklist> :> work-list
+ work-list [ in-sets out-sets dfa work-list dfa-step ] slurp-deque
+ in-sets
+ out-sets ; inline
+
+M: dataflow-analysis join-sets drop assoc-refine ;
+
+FUNCTOR: define-analysis ( name -- )
+
+name-analysis DEFINES-CLASS ${name}-analysis
+name-ins DEFINES ${name}-ins
+name-outs DEFINES ${name}-outs
+name-in DEFINES ${name}-in
+name-out DEFINES ${name}-out
+
+WHERE
+
+SINGLETON: name-analysis
+
+SYMBOL: name-ins
+
+: name-in ( bb -- set ) name-ins get at ;
+
+SYMBOL: name-outs
+
+: name-out ( bb -- set ) name-outs get at ;
+
+;FUNCTOR
+
+! ! ! Forward dataflow analysis
+
+MIXIN: forward-analysis
+INSTANCE: forward-analysis dataflow-analysis
+
+M: forward-analysis block-order drop reverse-post-order ;
+M: forward-analysis successors drop successors>> ;
+M: forward-analysis predecessors drop predecessors>> ;
+
+FUNCTOR: define-forward-analysis ( name -- )
+
+name-analysis IS ${name}-analysis
+name-ins IS ${name}-ins
+name-outs IS ${name}-outs
+compute-name-sets DEFINES compute-${name}-sets
+
+WHERE
+
+INSTANCE: name-analysis forward-analysis
+
+: compute-name-sets ( cfg -- )
+ name-analysis run-dataflow-analysis
+ [ name-ins set ] [ name-outs set ] bi* ;
+
+;FUNCTOR
+
+! ! ! Backward dataflow analysis
+
+MIXIN: backward-analysis
+INSTANCE: backward-analysis dataflow-analysis
+
+M: backward-analysis block-order drop post-order ;
+M: backward-analysis successors drop predecessors>> ;
+M: backward-analysis predecessors drop successors>> ;
+
+FUNCTOR: define-backward-analysis ( name -- )
+
+name-analysis IS ${name}-analysis
+name-ins IS ${name}-ins
+name-outs IS ${name}-outs
+compute-name-sets DEFINES compute-${name}-sets
+
+WHERE
+
+INSTANCE: name-analysis backward-analysis
+
+: compute-name-sets ( cfg -- )
+ \ name-analysis run-dataflow-analysis
+ [ name-outs set ] [ name-ins set ] bi* ;
+
+;FUNCTOR
+
+PRIVATE>
+
+SYNTAX: FORWARD-ANALYSIS:
+ scan [ define-analysis ] [ define-forward-analysis ] bi ;
+
+SYNTAX: BACKWARD-ANALYSIS:
+ scan [ define-analysis ] [ define-backward-analysis ] bi ;
-Slava Pestov
\ No newline at end of file
+Slava Pestov
+Daniel Ehrenberg
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test compiler.cfg kernel accessors compiler.cfg.dce
+compiler.cfg.instructions compiler.cfg.registers cpu.architecture ;
+IN: compiler.cfg.dce.tests
+
+: test-dce ( insns -- insns' )
+ <basic-block> swap >>instructions
+ cfg new swap >>entry
+ eliminate-dead-code
+ entry>> instructions>> ;
+
+[ V{
+ T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
+ T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
+ T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+ T{ ##replace { src V int-regs 3 } { loc D 0 } }
+} ] [ V{
+ T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
+ T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
+ T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+ T{ ##replace { src V int-regs 3 } { loc D 0 } }
+} test-dce ] unit-test
+
+[ V{ } ] [ V{
+ T{ ##load-immediate { dst V int-regs 1 } { val 8 } }
+ T{ ##load-immediate { dst V int-regs 2 } { val 16 } }
+ T{ ##add { dst V int-regs 3 } { src1 V int-regs 1 } { src2 V int-regs 2 } }
+} test-dce ] unit-test
+
+[ V{ } ] [ V{
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+} test-dce ] unit-test
+
+[ V{ } ] [ V{
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+} test-dce ] unit-test
+
+[ V{
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+} ] [ V{
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+} test-dce ] unit-test
+
+[ V{
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+} ] [ V{
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+} test-dce ] unit-test
+
+[ V{
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+} ] [ V{
+ T{ ##allot { dst V int-regs 1 } { temp V int-regs 2 } }
+ T{ ##replace { src V int-regs 1 } { loc D 0 } }
+ T{ ##load-immediate { dst V int-regs 3 } { val 8 } }
+ T{ ##set-slot-imm { obj V int-regs 1 } { src V int-regs 3 } }
+} test-dce ] unit-test
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sets kernel namespaces sequences
compiler.cfg.instructions compiler.cfg.def-use
! vregs which participate in side effects and thus are always live
SYMBOL: live-vregs
+: live-vreg? ( vreg -- ? )
+ live-vregs get key? ;
+
+! vregs which are the result of an allocation
+SYMBOL: allocations
+
+: allocation? ( vreg -- ? )
+ allocations get key? ;
+
: init-dead-code ( -- )
H{ } clone liveness-graph set
- H{ } clone live-vregs set ;
+ H{ } clone live-vregs set
+ H{ } clone allocations set ;
+
+GENERIC: build-liveness-graph ( insn -- )
+
+: add-edges ( insn register -- )
+ [ uses-vregs ] dip liveness-graph get [ union ] change-at ;
+
+: setter-liveness-graph ( insn vreg -- )
+ dup allocation? [ add-edges ] [ 2drop ] if ;
+
+M: ##set-slot build-liveness-graph
+ dup obj>> setter-liveness-graph ;
+
+M: ##set-slot-imm build-liveness-graph
+ dup obj>> setter-liveness-graph ;
+
+M: ##write-barrier build-liveness-graph
+ dup src>> setter-liveness-graph ;
+
+M: ##flushable build-liveness-graph
+ dup dst>> add-edges ;
-GENERIC: update-liveness-graph ( insn -- )
+M: ##allot build-liveness-graph
+ [ dst>> allocations get conjoin ]
+ [ call-next-method ] bi ;
-M: ##flushable update-liveness-graph
- [ uses-vregs ] [ dst>> ] bi liveness-graph get set-at ;
+M: insn build-liveness-graph drop ;
-: record-live ( vregs -- )
+GENERIC: compute-live-vregs ( insn -- )
+
+: (record-live) ( vregs -- )
[
dup live-vregs get key? [ drop ] [
[ live-vregs get conjoin ]
- [ liveness-graph get at record-live ]
+ [ liveness-graph get at (record-live) ]
bi
] if
] each ;
-M: insn update-liveness-graph uses-vregs record-live ;
+: record-live ( insn -- )
+ uses-vregs (record-live) ;
+
+: setter-live-vregs ( insn vreg -- )
+ allocation? [ drop ] [ record-live ] if ;
+
+M: ##set-slot compute-live-vregs
+ dup obj>> setter-live-vregs ;
+
+M: ##set-slot-imm compute-live-vregs
+ dup obj>> setter-live-vregs ;
+
+M: ##write-barrier compute-live-vregs
+ dup src>> setter-live-vregs ;
+
+M: ##flushable compute-live-vregs drop ;
+
+M: insn compute-live-vregs
+ record-live ;
GENERIC: live-insn? ( insn -- ? )
-M: ##flushable live-insn? dst>> live-vregs get key? ;
+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 ;
: eliminate-dead-code ( cfg -- cfg' )
init-dead-code
- [ [ instructions>> [ update-liveness-graph ] each ] each-basic-block ]
- [ [ [ [ live-insn? ] filter ] change-instructions drop ] each-basic-block ]
- [ ]
- tri ;
\ No newline at end of file
+ dup
+ [ [ instructions>> [ build-liveness-graph ] each ] each-basic-block ]
+ [ [ instructions>> [ compute-live-vregs ] each ] each-basic-block ]
+ [ [ instructions>> [ live-insn? ] filter-here ] each-basic-block ]
+ tri ;
--- /dev/null
+Dead code elimination
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words sequences quotations namespaces io
+USING: kernel words sequences quotations namespaces io vectors
classes.tuple accessors prettyprint prettyprint.config
prettyprint.backend prettyprint.custom prettyprint.sections
parser compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.linearization
compiler.cfg.registers compiler.cfg.stack-frame
compiler.cfg.linear-scan compiler.cfg.two-operand
-compiler.cfg.liveness compiler.cfg.optimizer
-compiler.cfg.mr ;
+compiler.cfg.optimizer
+compiler.cfg.mr compiler.cfg ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
] map ;
: insn. ( insn -- )
- tuple>array [ pprint bl ] each nl ;
+ tuple>array but-last [ pprint bl ] each nl ;
: mr. ( mrs -- )
[
M: ds-loc pprint* \ D pprint-loc ;
M: rs-loc pprint* \ R pprint-loc ;
+
+: test-bb ( insns n -- )
+ [ <basic-block> swap >>number swap >>instructions ] keep set ;
+
+: test-diamond ( -- )
+ 1 get 1vector 0 get (>>successors)
+ 2 get 3 get V{ } 2sequence 1 get (>>successors)
+ 4 get 1vector 2 get (>>successors)
+ 4 get 1vector 3 get (>>successors) ;
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel compiler.cfg.instructions ;
+USING: accessors arrays kernel assocs sequences
+sets compiler.cfg.instructions ;
IN: compiler.cfg.def-use
GENERIC: defs-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
M: ##flushable defs-vregs dst>> 1array ;
+M: ##fixnum-overflow defs-vregs dst>> 1array ;
M: insn defs-vregs drop f ;
M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
M: ##compare temp-vregs temp>> 1array ;
M: ##compare-imm temp-vregs temp>> 1array ;
M: ##compare-float temp-vregs temp>> 1array ;
-M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
-M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ;
M: _dispatch temp-vregs temp>> 1array ;
M: insn temp-vregs drop f ;
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>> ;
+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 ;
_conditional-branch
_compare-imm-branch
_dispatch ;
+
+: map-unique ( seq quot -- assoc )
+ map concat unique ; inline
+
+: gen-set ( instructions -- seq )
+ [ uses-vregs ] map-unique ;
+
+: kill-set ( instructions -- seq )
+ [ defs-vregs ] map-unique ;
--- /dev/null
+IN: compiler.cfg.dominance.tests
+USING: tools.test sequences vectors namespaces kernel accessors assocs sets
+math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger
+compiler.cfg.predecessors ;
+
+: test-dominance ( -- )
+ cfg new 0 get >>entry
+ compute-predecessors
+ compute-dominance ;
+
+! Example with no back edges
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ } 2 test-bb
+V{ } 3 test-bb
+V{ } 4 test-bb
+V{ } 5 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+1 get 3 get 1vector >>successors drop
+2 get 4 get 1vector >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 5 get 1vector >>successors drop
+
+[ ] [ test-dominance ] unit-test
+
+[ t ] [ 0 get dom-parent 0 get eq? ] unit-test
+[ t ] [ 1 get dom-parent 0 get eq? ] unit-test
+[ t ] [ 2 get dom-parent 0 get eq? ] unit-test
+[ t ] [ 4 get dom-parent 0 get eq? ] unit-test
+[ t ] [ 3 get dom-parent 1 get eq? ] unit-test
+[ t ] [ 5 get dom-parent 4 get eq? ] unit-test
+
+[ t ] [ 0 get dom-children 1 get 2 get 4 get 3array set= ] unit-test
+
+[ { 4 } ] [ 1 get dom-frontier [ number>> ] map ] unit-test
+[ { 4 } ] [ 2 get dom-frontier [ number>> ] map ] unit-test
+[ { } ] [ 0 get dom-frontier ] unit-test
+[ { } ] [ 4 get dom-frontier ] unit-test
+
+! Example from the paper
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ } 2 test-bb
+V{ } 3 test-bb
+V{ } 4 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+1 get 3 get 1vector >>successors drop
+2 get 4 get 1vector >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 3 get 1vector >>successors drop
+
+[ ] [ test-dominance ] unit-test
+
+[ t ] [ 0 4 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test
+
+! The other example from the paper
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ } 2 test-bb
+V{ } 3 test-bb
+V{ } 4 test-bb
+V{ } 5 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+1 get 5 get 1vector >>successors drop
+2 get 4 get 3 get V{ } 2sequence >>successors drop
+5 get 4 get 1vector >>successors drop
+4 get 5 get 3 get V{ } 2sequence >>successors drop
+3 get 4 get 1vector >>successors drop
+
+[ ] [ test-dominance ] unit-test
+
+[ t ] [ 0 5 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test
+
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ } 2 test-bb
+V{ } 3 test-bb
+V{ } 4 test-bb
+V{ } 5 test-bb
+V{ } 6 test-bb
+
+0 get 1 get 5 get V{ } 2sequence >>successors drop
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+2 get 4 get 1vector >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 6 get 1vector >>successors drop
+5 get 6 get 1vector >>successors drop
+
+[ ] [ test-dominance ] unit-test
+
+[ t ] [
+ 2 get 3 get 2array iterated-dom-frontier
+ 4 get 6 get 2array set=
+] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators compiler.cfg.rpo
-compiler.cfg.stack-analysis fry kernel math.order namespaces
-sequences ;
+USING: accessors assocs combinators sets math fry kernel math.order
+dlists deques namespaces sequences sorting compiler.cfg.rpo ;
IN: compiler.cfg.dominance
! Reference:
! Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy
! http://www.cs.rice.edu/~keith/EMBED/dom.pdf
-SYMBOL: idoms
+! Also, a nice overview is given in these lecture notes:
+! http://llvm.cs.uiuc.edu/~vadve/CS526/public_html/Notes/4ssa.4up.pdf
-: idom ( bb -- bb' ) idoms get at ;
+<PRIVATE
+
+! Maps bb -> idom(bb)
+SYMBOL: dom-parents
+
+PRIVATE>
+
+: dom-parent ( bb -- bb' ) dom-parents get at ;
<PRIVATE
-: set-idom ( idom bb -- changed? ) idoms get maybe-set-at ;
+: set-idom ( idom bb -- changed? )
+ dom-parents get maybe-set-at ;
: intersect ( finger1 finger2 -- bb )
2dup [ number>> ] compare {
- { +lt+ [ [ idom ] dip intersect ] }
- { +gt+ [ idom intersect ] }
+ { +gt+ [ [ dom-parent ] dip intersect ] }
+ { +lt+ [ dom-parent intersect ] }
[ 2drop ]
} case ;
: compute-idom ( bb -- idom )
- predecessors>> [ idom ] map sift
+ predecessors>> [ dom-parent ] filter
[ ] [ intersect ] map-reduce ;
: iterate ( rpo -- changed? )
[ [ compute-idom ] keep set-idom ] map [ ] any? ;
+: compute-dom-parents ( cfg -- )
+ H{ } clone dom-parents set
+ reverse-post-order
+ unclip dup set-idom drop '[ _ iterate ] loop ;
+
+! Maps bb -> {bb' | idom(bb') = bb}
+SYMBOL: dom-childrens
+
+PRIVATE>
+
+: dom-children ( bb -- seq ) dom-childrens get at ;
+
+<PRIVATE
+
+: compute-dom-children ( -- )
+ dom-parents get H{ } clone
+ [ '[ 2dup eq? [ 2drop ] [ _ push-at ] if ] assoc-each ] keep
+ dom-childrens set ;
+
+! Maps bb -> DF(bb)
+SYMBOL: dom-frontiers
+
+PRIVATE>
+
+: dom-frontier ( bb -- set ) dom-frontiers get at keys ;
+
+<PRIVATE
+
+: compute-dom-frontier ( bb pred -- )
+ 2dup [ dom-parent ] dip eq? [ 2drop ] [
+ [ dom-frontiers get conjoin-at ]
+ [ dom-parent compute-dom-frontier ] 2bi
+ ] if ;
+
+: compute-dom-frontiers ( cfg -- )
+ H{ } clone dom-frontiers set
+ [
+ dup predecessors>> dup length 2 >= [
+ [ compute-dom-frontier ] with each
+ ] [ 2drop ] if
+ ] each-basic-block ;
+
+PRIVATE>
+
+: compute-dominance ( cfg -- )
+ [ compute-dom-parents compute-dom-children ]
+ [ compute-dom-frontiers ]
+ bi ;
+
+<PRIVATE
+
+SYMBOLS: work-list visited ;
+
+: add-to-work-list ( bb -- )
+ dom-frontier work-list get push-all-front ;
+
+: iterated-dom-frontier-step ( bb -- )
+ dup visited get key? [ drop ] [
+ [ visited get conjoin ]
+ [ add-to-work-list ] bi
+ ] if ;
+
PRIVATE>
-: compute-dominance ( cfg -- cfg )
- H{ } clone idoms set
- dup reverse-post-order
- unclip dup set-idom drop '[ _ iterate ] loop ;
\ No newline at end of file
+: iterated-dom-frontier ( bbs -- bbs' )
+ [
+ <dlist> work-list set
+ H{ } clone visited set
+ [ add-to-work-list ] each
+ work-list get [ iterated-dom-frontier-step ] slurp-deque
+ visited get keys
+ ] with-scope ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences assocs
-cpu.architecture compiler.cfg.rpo
-compiler.cfg.liveness compiler.cfg.instructions
+compiler.cfg.rpo compiler.cfg.instructions
compiler.cfg.hats ;
IN: compiler.cfg.gc-checks
: gc? ( bb -- ? )
instructions>> [ ##allocation? ] any? ;
-: object-pointer-regs ( basic-block -- vregs )
- live-in keys [ reg-class>> int-regs eq? ] filter ;
-
: insert-gc-check ( basic-block -- )
dup gc? [
- [ i i f f \ ##gc new-insn prefix ] change-instructions drop
+ [ i i f \ ##gc new-insn prefix ] change-instructions drop
] [ drop ] if ;
: insert-gc-checks ( cfg -- cfg' )
: ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline
: ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline
: ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline
+: ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline
: ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline
: ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline
: ^^and ( input mask -- output ) ^^i2 ##and ; inline
: ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline
: ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline
: ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline
+: ^^shl ( src1 src2 -- dst ) ^^i2 ##shl ; inline
: ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline
+: ^^shr ( src1 src2 -- dst ) ^^i2 ##shr ; inline
: ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
+: ^^sar ( src1 src2 -- dst ) ^^i2 ##sar ; inline
: ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
: ^^not ( src -- dst ) ^^i1 ##not ; inline
: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline
: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
: ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
: ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
-
+: ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline
+: ^^fixnum-sub ( src1 src2 -- dst ) ^^i2 ##fixnum-sub ; inline
+: ^^fixnum-mul ( src1 src2 -- dst ) ^^i2 ##fixnum-mul ; inline
: ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline
\ 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 math namespaces sequences kernel fry
-compiler.cfg compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.liveness compiler.cfg.local ;
-IN: compiler.cfg.height
-
-! Combine multiple stack height changes into one at the
-! start of the basic block.
-
-SYMBOL: ds-height
-SYMBOL: rs-height
-
-GENERIC: compute-heights ( insn -- )
-
-M: ##inc-d compute-heights n>> ds-height [ + ] change ;
-M: ##inc-r compute-heights n>> rs-height [ + ] change ;
-M: insn compute-heights drop ;
-
-GENERIC: normalize-height* ( insn -- insn' )
-
-: normalize-inc-d/r ( insn stack -- insn' )
- swap n>> '[ _ - ] change f ; inline
-
-M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
-M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
-
-GENERIC: loc-stack ( loc -- stack )
-
-M: ds-loc loc-stack drop ds-height ;
-M: rs-loc loc-stack drop rs-height ;
-
-GENERIC: <loc> ( n stack -- loc )
-
-M: ds-loc <loc> drop <ds-loc> ;
-M: rs-loc <loc> drop <rs-loc> ;
-
-: normalize-peek/replace ( insn -- insn' )
- [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
-
-M: ##peek normalize-height* normalize-peek/replace ;
-M: ##replace normalize-height* normalize-peek/replace ;
-
-M: insn normalize-height* ;
-
-: height-step ( insns -- insns' )
- 0 ds-height set
- 0 rs-height set
- [ [ compute-heights ] each ]
- [ [ [ normalize-height* ] map sift ] with-scope ] bi
- ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
- rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
-
-: normalize-height ( cfg -- cfg' )
- [ drop ] [ height-step ] local-optimization ;
+++ /dev/null
-Stack height normalization coalesces height changes at start of basic block
! Subroutine calls
INSN: ##stack-frame stack-frame ;
-INSN: ##call word { height integer } ;
+INSN: ##call word ;
INSN: ##jump word ;
INSN: ##return ;
+! Dummy instruction that simply inhibits TCO
+INSN: ##no-tco ;
+
! Jump tables
INSN: ##dispatch src temp ;
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: ##not < ##unary ;
INSN: ##log2 < ##unary ;
-! Overflowing arithmetic
-TUPLE: ##fixnum-overflow < insn src1 src2 ;
-INSN: ##fixnum-add < ##fixnum-overflow ;
-INSN: ##fixnum-add-tail < ##fixnum-overflow ;
-INSN: ##fixnum-sub < ##fixnum-overflow ;
-INSN: ##fixnum-sub-tail < ##fixnum-overflow ;
-INSN: ##fixnum-mul < ##fixnum-overflow temp1 temp2 ;
-INSN: ##fixnum-mul-tail < ##fixnum-overflow temp1 temp2 ;
-
: ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline
: ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline
INSN: ##phi < ##pure inputs ;
-! Condition codes
-SYMBOL: cc<
-SYMBOL: cc<=
-SYMBOL: cc=
-SYMBOL: cc>
-SYMBOL: cc>=
-SYMBOL: cc/=
-
-: negate-cc ( cc -- cc' )
- H{
- { cc< cc>= }
- { cc<= cc> }
- { cc> cc<= }
- { cc>= cc< }
- { cc= cc/= }
- { cc/= cc= }
- } at ;
-
-: evaluate-cc ( result cc -- ? )
- H{
- { cc< { +lt+ } }
- { cc<= { +lt+ +eq+ } }
- { cc= { +eq+ } }
- { cc>= { +eq+ +gt+ } }
- { cc> { +gt+ } }
- { cc/= { +lt+ +gt+ } }
- } at memq? ;
-
+! Conditionals
TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
INSN: ##compare-branch < ##conditional-branch ;
INSN: ##compare-float-branch < ##conditional-branch ;
INSN: ##compare-float < ##binary cc temp ;
-INSN: ##gc { temp1 vreg } { temp2 vreg } live-registers live-spill-slots ;
+! Overflowing arithmetic
+TUPLE: ##fixnum-overflow < insn { dst vreg } { src1 vreg } { src2 vreg } ;
+INSN: ##fixnum-add < ##fixnum-overflow ;
+INSN: ##fixnum-sub < ##fixnum-overflow ;
+INSN: ##fixnum-mul < ##fixnum-overflow ;
+
+INSN: ##gc { temp1 vreg } { temp2 vreg } live-values ;
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;
INSN: _compare-float-branch < _conditional-branch ;
+! Overflowing arithmetic
+TUPLE: _fixnum-overflow < insn label { dst vreg } { src1 vreg } { src2 vreg } ;
+INSN: _fixnum-add < _fixnum-overflow ;
+INSN: _fixnum-sub < _fixnum-overflow ;
+INSN: _fixnum-mul < _fixnum-overflow ;
+
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
INSN: _reload dst class n ;
INSN: _copy dst src class ;
INSN: _spill-counts counts ;
+
+! Instructions that poison the stack state
+UNION: poison-insn
+ ##jump
+ ##return
+ ##callback-return ;
+
+! Instructions that kill all live vregs
+UNION: kill-vreg-insn
+ poison-insn
+ ##stack-frame
+ ##call
+ ##prologue
+ ##epilogue
+ ##alien-invoke
+ ##alien-indirect
+ ##alien-callback ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences accessors layouts kernel math namespaces
-combinators fry locals
+USING: sequences accessors layouts kernel math math.intervals
+namespaces combinators fry arrays
compiler.tree.propagation.info
compiler.cfg.hats
compiler.cfg.stacks
-compiler.cfg.iterator
compiler.cfg.instructions
compiler.cfg.utilities
-compiler.cfg.registers ;
+compiler.cfg.registers
+compiler.cfg.comparisons ;
IN: compiler.cfg.intrinsics.fixnum
: emit-both-fixnums? ( -- )
0 cc= ^^compare-imm
ds-push ;
-: (emit-fixnum-imm-op) ( infos insn -- dst )
- ds-drop
- [ ds-pop ]
- [ second literal>> [ tag-fixnum ] [ \ f tag-number ] if* ]
- [ ]
- tri*
- call ; inline
-
-: (emit-fixnum-op) ( insn -- dst )
- [ 2inputs ] dip call ; inline
-
-:: emit-fixnum-op ( node insn imm-insn -- )
- [let | infos [ node node-input-infos ] |
- infos second value-info-small-tagged?
- [ infos imm-insn (emit-fixnum-imm-op) ]
- [ insn (emit-fixnum-op) ]
- if
- ds-push
- ] ; inline
+: tag-literal ( n -- tagged )
+ literal>> [ tag-fixnum ] [ \ f tag-number ] if* ;
-: emit-fixnum-shift-fast ( node -- )
- dup node-input-infos dup second value-info-small-fixnum? [
- nip
- [ ds-drop ds-pop ] dip
- second literal>> dup sgn {
- { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] }
- { 0 [ drop ] }
- { 1 [ ^^shl-imm ] }
- } case
- ds-push
- ] [ drop emit-primitive ] if ;
+: emit-fixnum-op ( insn -- )
+ [ 2inputs ] dip call ds-push ; inline
+
+: emit-fixnum-left-shift ( -- )
+ [ ^^untag-fixnum ^^shl ] emit-fixnum-op ;
+
+: emit-fixnum-right-shift ( -- )
+ [ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ;
+
+: emit-fixnum-shift-general ( -- )
+ D 0 ^^peek 0 cc> ##compare-imm-branch
+ [ emit-fixnum-left-shift ] with-branch
+ [ emit-fixnum-right-shift ] with-branch
+ 2array emit-conditional ;
+: emit-fixnum-shift-fast ( node -- )
+ node-input-infos second interval>> {
+ { [ dup 0 [a,inf] interval-subset? ] [ drop emit-fixnum-left-shift ] }
+ { [ dup 0 [-inf,a] interval-subset? ] [ drop emit-fixnum-right-shift ] }
+ [ drop emit-fixnum-shift-general ]
+ } cond ;
+
: emit-fixnum-bitnot ( -- )
ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
: emit-fixnum-log2 ( -- )
ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
-: (emit-fixnum*fast) ( -- dst )
- 2inputs ^^untag-fixnum ^^mul ;
-
-: (emit-fixnum*fast-imm) ( infos -- dst )
- ds-drop
- [ ds-pop ] [ second literal>> ] bi* ^^mul-imm ;
-
-: emit-fixnum*fast ( node -- )
- node-input-infos
- dup second value-info-small-fixnum?
- [ (emit-fixnum*fast-imm) ] [ drop (emit-fixnum*fast) ] if
- ds-push ;
+: emit-fixnum*fast ( -- )
+ 2inputs ^^untag-fixnum ^^mul ds-push ;
-: emit-fixnum-comparison ( node cc -- )
- [ ^^compare ] [ ^^compare-imm ] bi-curry
- emit-fixnum-op ;
+: emit-fixnum-comparison ( cc -- )
+ '[ _ ^^compare ] emit-fixnum-op ;
: emit-bignum>fixnum ( -- )
ds-pop ^^bignum>integer ^^tag-fixnum ds-push ;
: emit-fixnum>bignum ( -- )
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
-: emit-fixnum-overflow-op ( quot quot-tail -- next )
- [ 2inputs 1 ##inc-d ] 2dip
- tail-call? [
- ##epilogue
- nip call
- stop-iterating
- ] [
- drop call
- ##branch
- begin-basic-block
- iterate-next
- ] if ; inline
+: emit-no-overflow-case ( dst -- final-bb )
+ [ -2 ##inc-d ds-push ] with-branch ;
+
+: emit-overflow-case ( word -- final-bb )
+ [ ##call ] with-branch ;
+
+: emit-fixnum-overflow-op ( quot word -- )
+ [ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip
+ [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
+ emit-conditional ; inline
+
+: fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ;
+
+: fixnum-overflow ( x y -- z ) [ >bignum ] bi@ - ;
+
+: fixnum*overflow ( x y -- z ) [ >bignum ] bi@ * ;
+
+: emit-fixnum+ ( -- )
+ [ ^^fixnum-add ] \ fixnum+overflow emit-fixnum-overflow-op ;
+
+: emit-fixnum- ( -- )
+ [ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ;
+
+: emit-fixnum* ( -- )
+ [ ^^untag-fixnum ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ;
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel combinators cpu.architecture
compiler.cfg.hats
compiler.cfg.intrinsics.float
compiler.cfg.intrinsics.slots
compiler.cfg.intrinsics.misc
-compiler.cfg.iterator ;
+compiler.cfg.comparisons ;
QUALIFIED: kernel
QUALIFIED: arrays
QUALIFIED: byte-arrays
math.private:fixnum<=
math.private:fixnum>=
math.private:fixnum>
- math.private:bignum>fixnum
- math.private:fixnum>bignum
+ ! math.private:bignum>fixnum
+ ! math.private:fixnum>bignum
kernel:eq?
slots.private:slot
slots.private:set-slot
: enable-fixnum-log2 ( -- )
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
-: emit-intrinsic ( node word -- node/f )
+: emit-intrinsic ( node word -- )
{
- { \ kernel.private:tag [ drop emit-tag iterate-next ] }
- { \ kernel.private:getenv [ emit-getenv iterate-next ] }
- { \ math.private:both-fixnums? [ drop emit-both-fixnums? iterate-next ] }
- { \ math.private:fixnum+ [ drop [ ##fixnum-add ] [ ##fixnum-add-tail ] emit-fixnum-overflow-op ] }
- { \ math.private:fixnum- [ drop [ ##fixnum-sub ] [ ##fixnum-sub-tail ] emit-fixnum-overflow-op ] }
- { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] [ i i ##fixnum-mul-tail ] emit-fixnum-overflow-op ] }
- { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-fixnum-op iterate-next ] }
- { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op iterate-next ] }
- { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-fixnum-op iterate-next ] }
- { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-fixnum-op iterate-next ] }
- { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
- { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
- { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
- { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
- { \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
- { \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
- { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }
- { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison iterate-next ] }
- { \ math.private:fixnum> [ cc> emit-fixnum-comparison iterate-next ] }
- { \ kernel:eq? [ cc= emit-fixnum-comparison iterate-next ] }
- { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum iterate-next ] }
- { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum iterate-next ] }
- { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op iterate-next ] }
- { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op iterate-next ] }
- { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op iterate-next ] }
- { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op iterate-next ] }
- { \ math.private:float< [ drop cc< emit-float-comparison iterate-next ] }
- { \ math.private:float<= [ drop cc<= emit-float-comparison iterate-next ] }
- { \ math.private:float>= [ drop cc>= emit-float-comparison iterate-next ] }
- { \ math.private:float> [ drop cc> emit-float-comparison iterate-next ] }
- { \ math.private:float= [ drop cc= emit-float-comparison iterate-next ] }
- { \ math.private:float>fixnum [ drop emit-float>fixnum iterate-next ] }
- { \ math.private:fixnum>float [ drop emit-fixnum>float iterate-next ] }
- { \ slots.private:slot [ emit-slot iterate-next ] }
- { \ slots.private:set-slot [ emit-set-slot iterate-next ] }
- { \ strings.private:string-nth [ drop emit-string-nth iterate-next ] }
- { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast iterate-next ] }
- { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> iterate-next ] }
- { \ arrays:<array> [ emit-<array> iterate-next ] }
- { \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
- { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
- { \ kernel:<wrapper> [ emit-simple-allot iterate-next ] }
- { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] }
- { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter iterate-next ] }
- { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter iterate-next ] }
- { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter iterate-next ] }
- { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter iterate-next ] }
- { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter iterate-next ] }
- { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter iterate-next ] }
- { \ alien.accessors:alien-cell [ emit-alien-cell-getter iterate-next ] }
- { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter iterate-next ] }
- { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter iterate-next ] }
- { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter iterate-next ] }
- { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter iterate-next ] }
- { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter iterate-next ] }
+ { \ kernel.private:tag [ drop emit-tag ] }
+ { \ kernel.private:getenv [ emit-getenv ] }
+ { \ math.private:both-fixnums? [ drop emit-both-fixnums? ] }
+ { \ math.private:fixnum+ [ drop emit-fixnum+ ] }
+ { \ math.private:fixnum- [ drop emit-fixnum- ] }
+ { \ math.private:fixnum* [ drop emit-fixnum* ] }
+ { \ math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] }
+ { \ math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] }
+ { \ math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] }
+ { \ math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] }
+ { \ math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] }
+ { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] }
+ { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] }
+ { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
+ { \ math.private:fixnum*fast [ drop emit-fixnum*fast ] }
+ { \ math.private:fixnum< [ drop cc< emit-fixnum-comparison ] }
+ { \ math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] }
+ { \ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] }
+ { \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] }
+ { \ kernel:eq? [ drop cc= emit-fixnum-comparison ] }
+ { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] }
+ { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] }
+ { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] }
+ { \ math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
+ { \ math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
+ { \ math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
+ { \ math.private:float< [ drop cc< emit-float-comparison ] }
+ { \ math.private:float<= [ drop cc<= emit-float-comparison ] }
+ { \ math.private:float>= [ drop cc>= emit-float-comparison ] }
+ { \ math.private:float> [ drop cc> emit-float-comparison ] }
+ { \ math.private:float= [ drop cc= emit-float-comparison ] }
+ { \ math.private:float>fixnum [ drop emit-float>fixnum ] }
+ { \ math.private:fixnum>float [ drop emit-fixnum>float ] }
+ { \ slots.private:slot [ emit-slot ] }
+ { \ slots.private:set-slot [ emit-set-slot ] }
+ { \ strings.private:string-nth [ drop emit-string-nth ] }
+ { \ strings.private:set-string-nth-fast [ drop emit-set-string-nth-fast ] }
+ { \ classes.tuple.private:<tuple-boa> [ emit-<tuple-boa> ] }
+ { \ arrays:<array> [ emit-<array> ] }
+ { \ byte-arrays:<byte-array> [ emit-<byte-array> ] }
+ { \ byte-arrays:(byte-array) [ emit-(byte-array) ] }
+ { \ kernel:<wrapper> [ emit-simple-allot ] }
+ { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter ] }
+ { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-signed-1 [ 1 emit-alien-signed-getter ] }
+ { \ alien.accessors:set-alien-signed-1 [ 1 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-unsigned-2 [ 2 emit-alien-unsigned-getter ] }
+ { \ alien.accessors:set-alien-unsigned-2 [ 2 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-signed-2 [ 2 emit-alien-signed-getter ] }
+ { \ alien.accessors:set-alien-signed-2 [ 2 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-unsigned-4 [ 4 emit-alien-unsigned-getter ] }
+ { \ alien.accessors:set-alien-unsigned-4 [ 4 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-signed-4 [ 4 emit-alien-signed-getter ] }
+ { \ alien.accessors:set-alien-signed-4 [ 4 emit-alien-integer-setter ] }
+ { \ alien.accessors:alien-cell [ emit-alien-cell-getter ] }
+ { \ alien.accessors:set-alien-cell [ emit-alien-cell-setter ] }
+ { \ alien.accessors:alien-float [ single-float-regs emit-alien-float-getter ] }
+ { \ alien.accessors:set-alien-float [ single-float-regs emit-alien-float-setter ] }
+ { \ alien.accessors:alien-double [ double-float-regs emit-alien-float-getter ] }
+ { \ alien.accessors:set-alien-double [ double-float-regs emit-alien-float-setter ] }
} case ;
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces sequences kernel compiler.tree ;
-IN: compiler.cfg.iterator
-
-SYMBOL: node-stack
-
-: >node ( cursor -- ) node-stack get push ;
-: node> ( -- cursor ) node-stack get pop ;
-: node@ ( -- cursor ) node-stack get last ;
-: current-node ( -- node ) node@ first ;
-: iterate-next ( -- cursor ) node@ rest-slice ;
-: skip-next ( -- next ) node> rest-slice [ first ] [ >node ] bi ;
-
-: iterate-nodes ( cursor quot: ( -- ) -- )
- over empty? [
- 2drop
- ] [
- [ swap >node call node> drop ] keep iterate-nodes
- ] if ; inline recursive
-
-DEFER: (tail-call?)
-
-: tail-phi? ( cursor -- ? )
- [ first #phi? ] [ rest-slice (tail-call?) ] bi and ;
-
-: (tail-call?) ( cursor -- ? )
- [ t ] [
- [
- first
- [ #return? ]
- [ #return-recursive? ]
- [ #terminate? ] tri or or
- ] [ tail-phi? ] bi or
- ] if-empty ;
-
-: tail-call? ( -- ? )
- node-stack get [
- rest-slice
- [ t ] [ (tail-call?) ] if-empty
- ] all? ;
-
-: terminate-call? ( -- ? )
- node-stack get last
- rest-slice [ f ] [ first #terminate? ] if-empty ;
+++ /dev/null
-Utility for iterating for high-level IR
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs heaps kernel namespaces sequences fry math
-combinators arrays sorting compiler.utilities
+math.order combinators arrays sorting compiler.utilities
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation.coalescing
compiler.cfg.linear-scan.allocation.spilling
compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.allocation
-: free-positions ( new -- assoc )
- vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
+: active-positions ( new assoc -- )
+ [ vreg>> active-intervals-for ] dip
+ '[ [ 0 ] dip reg>> _ add-use-position ] each ;
-: active-positions ( new -- assoc )
- vreg>> active-intervals-for [ reg>> 0 ] H{ } map>assoc ;
+: inactive-positions ( new assoc -- )
+ [ [ vreg>> inactive-intervals-for ] keep ] dip
+ '[
+ [ _ relevant-ranges intersect-live-ranges 1/0. or ] [ reg>> ] bi
+ _ add-use-position
+ ] each ;
-: inactive-positions ( new -- assoc )
- dup vreg>> inactive-intervals-for
- [ [ reg>> swap ] keep relevant-ranges intersect-live-ranges ]
- with H{ } map>assoc ;
-
-: compute-free-pos ( new -- free-pos )
- [ free-positions ] [ inactive-positions ] [ active-positions ] tri
- 3array assoc-combine >alist alist-max ;
+: register-status ( new -- free-pos )
+ dup free-positions
+ [ inactive-positions ] [ active-positions ] [ nip ] 2tri
+ >alist alist-max ;
: no-free-registers? ( result -- ? )
second 0 = ; inline
-: register-available? ( new result -- ? )
- [ end>> ] [ second ] bi* < ; inline
-
-: register-available ( new result -- )
- first >>reg add-active ;
+: split-to-fit ( new n -- before after )
+ split-interval
+ [ [ compute-start/end ] bi@ ]
+ [ >>split-next drop ]
+ [ ]
+ 2tri ;
: register-partially-available ( new result -- )
- [ second split-before-use ] keep
- '[ _ register-available ] [ add-unhandled ] bi* ;
+ {
+ { [ 2dup second 1 - spill-live-out? ] [ drop spill-live-out ] }
+ { [ 2dup second 1 - spill-live-in? ] [ drop spill-live-in ] }
+ [
+ [ second 1 - split-to-fit ] keep
+ '[ _ register-available ] [ add-unhandled ] bi*
+ ]
+ } cond ;
: assign-register ( new -- )
dup coalesce? [ coalesce ] [
- dup compute-free-pos {
+ dup register-status {
{ [ dup no-free-registers? ] [ drop assign-blocked-register ] }
{ [ 2dup register-available? ] [ register-available ] }
- [ register-partially-available ]
+ ! [ register-partially-available ]
+ [ drop assign-blocked-register ]
} cond
] if ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences
+USING: accessors kernel sequences namespaces assocs fry
combinators.short-circuit
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation.state ;
: active-interval ( vreg -- live-interval )
dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
-: intersects-inactive-intervals? ( live-interval -- ? )
+: avoids-inactive-intervals? ( live-interval -- ? )
dup vreg>> inactive-intervals-for
- [ relevant-ranges intersect-live-ranges 1/0. = ] with all? ;
+ [ intervals-intersect? not ] with all? ;
: coalesce? ( live-interval -- ? )
{
[ copy-from>> active-interval ]
[ [ start>> ] [ copy-from>> active-interval end>> ] bi = ]
- [ intersects-inactive-intervals? ]
+ [ avoids-inactive-intervals? ]
} 1&& ;
+: reuse-spill-slot ( old new -- )
+ [ vreg>> spill-slots get at ] dip '[ _ vreg>> spill-slots get set-at ] when* ;
+
+: reuse-register ( old new -- )
+ reg>> >>reg drop ;
+
+: (coalesce) ( old new -- )
+ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ;
+
: coalesce ( live-interval -- )
dup copy-from>> active-interval
- [ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ]
- [ reg>> >>reg drop ]
- 2bi ;
+ [ reuse-spill-slot ] [ reuse-register ] [ (coalesce) ] 2tri ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
-math sequences sets sorting splitting compiler.utilities
+math sequences sets sorting splitting namespaces
+combinators.short-circuit compiler.utilities
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.spilling
-: find-use ( live-interval n quot -- elt )
- [ uses>> ] 2dip curry find nip ; inline
+ERROR: bad-live-ranges interval ;
-: spill-existing? ( new existing -- ? )
- #! Test if 'new' will be used before 'existing'.
- over start>> '[ _ [ > ] find-use -1 or ] bi@ < ;
+: check-ranges ( live-interval -- )
+ check-allocation? get [
+ dup ranges>> [ [ from>> ] [ to>> ] bi <= ] all?
+ [ drop ] [ bad-live-ranges ] if
+ ] [ drop ] if ;
-: interval-to-spill ( active-intervals current -- live-interval )
- #! We spill the interval with the most distant use location.
- start>> '[ dup _ [ >= ] find-use ] { } map>assoc
- alist-max first ;
+: trim-before-ranges ( live-interval -- )
+ [ ranges>> ] [ uses>> last 1 + ] bi
+ [ '[ from>> _ <= ] filter-here ]
+ [ swap last (>>to) ]
+ 2bi ;
+
+: trim-after-ranges ( live-interval -- )
+ [ ranges>> ] [ uses>> first ] bi
+ [ '[ to>> _ >= ] filter-here ]
+ [ swap first (>>from) ]
+ 2bi ;
: split-for-spill ( live-interval n -- before after )
split-interval
+ {
+ [ [ trim-before-ranges ] [ trim-after-ranges ] bi* ]
+ [ [ compute-start/end ] bi@ ]
+ [ [ check-ranges ] bi@ ]
+ [ ]
+ } 2cleave ;
+
+: assign-spill ( live-interval -- )
+ dup vreg>> assign-spill-slot >>spill-to f >>split-next drop ;
+
+: assign-reload ( live-interval -- )
+ dup vreg>> assign-spill-slot >>reload-from drop ;
+
+: split-and-spill ( live-interval n -- before after )
+ split-for-spill 2dup [ assign-spill ] [ assign-reload ] bi* ;
+
+: find-use-position ( live-interval new -- n )
+ [ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ;
+
+: find-use-positions ( live-intervals new assoc -- )
+ '[ [ _ find-use-position ] [ reg>> ] bi _ add-use-position ] each ;
+
+: active-positions ( new assoc -- )
+ [ [ vreg>> active-intervals-for ] keep ] dip
+ find-use-positions ;
+
+: inactive-positions ( new assoc -- )
[
- [ [ ranges>> last ] [ uses>> last ] bi >>to drop ]
- [ [ ranges>> first ] [ uses>> first ] bi >>from drop ] bi*
- ]
- [ [ compute-start/end ] bi@ ]
- [ ]
- 2tri ;
-
-: assign-spill ( before after -- before after )
- #! If it has been spilled already, reuse spill location.
- over reload-from>>
- [ over vreg>> reg-class>> next-spill-location ] unless*
- [ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
-
-: split-and-spill ( new existing -- before after )
- swap start>> split-for-spill assign-spill ;
-
-: spill-existing ( new existing -- )
- #! Our new interval will be used before the active interval
- #! with the most distant use location. Spill the existing
- #! interval, then process the new interval and the tail end
- #! of the existing interval again.
- [ nip delete-active ]
- [ reg>> >>reg add-active ]
- [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ] 2tri ;
-
-: spill-new ( new existing -- )
- #! Our new interval will be used after the active interval
- #! with the most distant use location. Split the new
- #! interval, then process both parts of the new interval
- #! again.
- [ dup split-and-spill add-unhandled ] dip spill-existing ;
+ [ vreg>> inactive-intervals-for ] keep
+ [ '[ _ intervals-intersect? ] filter ] keep
+ ] dip
+ find-use-positions ;
-: assign-blocked-register ( new -- )
- [ dup vreg>> active-intervals-for ] keep interval-to-spill
- 2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
+: spill-status ( new -- use-pos )
+ H{ } clone
+ [ inactive-positions ] [ active-positions ] [ nip ] 2tri
+ >alist alist-max ;
+
+: spill-new? ( new pair -- ? )
+ [ uses>> first ] [ second ] bi* > ;
+
+: spill-new ( new pair -- )
+ drop
+ {
+ [ trim-after-ranges ]
+ [ compute-start/end ]
+ [ assign-reload ]
+ [ add-unhandled ]
+ } cleave ;
+: spill-live-out? ( live-interval n -- ? ) [ uses>> last ] dip < ;
+
+: spill-live-out ( live-interval -- )
+ ! The interval has no more usages after the spill location. This
+ ! means it is the first child of an interval that was split. We
+ ! spill the value and let the resolve pass insert a reload later.
+ {
+ [ trim-before-ranges ]
+ [ compute-start/end ]
+ [ assign-spill ]
+ [ add-handled ]
+ } cleave ;
+
+: spill-live-in? ( live-interval n -- ? ) [ uses>> first ] dip > ;
+
+: spill-live-in ( live-interval -- )
+ ! The interval does not have any usages before the spill location.
+ ! This means it is the second child of an interval that was
+ ! split. We reload the value and let the resolve pass insert a
+ ! split later.
+ {
+ [ trim-after-ranges ]
+ [ compute-start/end ]
+ [ assign-reload ]
+ [ add-unhandled ]
+ } cleave ;
+
+: spill ( live-interval n -- )
+ {
+ { [ 2dup spill-live-out? ] [ drop spill-live-out ] }
+ { [ 2dup spill-live-in? ] [ drop spill-live-in ] }
+ [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ]
+ } cond ;
+
+:: spill-intersecting-active ( new reg -- )
+ ! If there is an active interval using 'reg' (there should be at
+ ! most one) are split and spilled and removed from the inactive
+ ! set.
+ new vreg>> active-intervals-for [ [ reg>> reg = ] find swap dup ] keep
+ '[ _ delete-nth new start>> spill ] [ 2drop ] if ;
+
+:: spill-intersecting-inactive ( new reg -- )
+ ! Any inactive intervals using 'reg' are split and spilled
+ ! and removed from the inactive set.
+ new vreg>> inactive-intervals-for [
+ dup reg>> reg = [
+ dup new intervals-intersect? [
+ new start>> spill f
+ ] [ drop t ] if
+ ] [ drop t ] if
+ ] filter-here ;
+
+: spill-intersecting ( new reg -- )
+ ! Split and spill all active and inactive intervals
+ ! which intersect 'new' and use 'reg'.
+ [ spill-intersecting-active ]
+ [ spill-intersecting-inactive ]
+ 2bi ;
+
+: spill-available ( new pair -- )
+ ! A register would become fully available if all
+ ! active and inactive intervals using it were split
+ ! and spilled.
+ [ first spill-intersecting ] [ register-available ] 2bi ;
+
+: spill-partially-available ( new pair -- )
+ ! A register would be available for part of the new
+ ! interval's lifetime if all active and inactive intervals
+ ! using that register were split and spilled.
+ [ second 1 - split-and-spill add-unhandled ] keep
+ spill-available ;
+
+: assign-blocked-register ( new -- )
+ dup spill-status {
+ { [ 2dup spill-new? ] [ spill-new ] }
+ { [ 2dup register-available? ] [ spill-available ] }
+ [ spill-partially-available ]
+ } cond ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
-math sequences sets sorting splitting
+math sequences sets sorting splitting namespaces
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.splitting
ERROR: splitting-too-early ;
+ERROR: splitting-too-late ;
+
ERROR: splitting-atomic-interval ;
: check-split ( live-interval n -- )
- [ [ start>> ] dip > [ splitting-too-early ] when ]
- [ drop [ end>> ] [ start>> ] bi - 0 = [ splitting-atomic-interval ] when ]
- 2bi ; inline
+ check-allocation? get [
+ [ [ start>> ] dip > [ splitting-too-early ] when ]
+ [ [ end>> ] dip <= [ splitting-too-late ] when ]
+ [ drop [ end>> ] [ start>> ] bi = [ splitting-atomic-interval ] when ]
+ 2tri
+ ] [ 2drop ] if ; inline
: split-before ( before -- before' )
f >>spill-to ; inline
after split-after ;
HINTS: split-interval live-interval object ;
-
-: split-between-blocks ( new n -- before after )
- split-interval
- 2dup [ compute-start/end ] bi@ ;
-
-: insert-use-for-copy ( seq n -- seq' )
- dup 1 + [ nip 1array split1 ] 2keep 2array glue ;
-
-: split-before-use ( new n -- before after )
- ! Find optimal split position
- ! Insert move instruction
- 1 -
- 2dup swap covers? [
- [ '[ _ insert-use-for-copy ] change-uses ] keep
- split-between-blocks
- 2dup >>split-next drop
- ] [
- split-between-blocks
- ] if ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators cpu.architecture fry heaps
-kernel math namespaces sequences vectors
+kernel math math.order namespaces sequences vectors
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.state
+! Start index of current live interval. We ensure that all
+! live intervals added to the unhandled set have a start index
+! strictly greater than this one. This ensures that we can catch
+! infinite loop situations. We also ensure that all live
+! intervals added to the handled set have an end index strictly
+! smaller than this one. This helps catch bugs.
+SYMBOL: progress
+
+: check-unhandled ( live-interval -- )
+ start>> progress get <= [ "check-unhandled" throw ] when ; inline
+
+: check-handled ( live-interval -- )
+ end>> progress get > [ "check-handled" throw ] when ; inline
+
! Mapping from register classes to sequences of machine registers
SYMBOL: registers
: add-inactive ( live-interval -- )
dup vreg>> inactive-intervals-for push ;
+: delete-inactive ( live-interval -- )
+ dup vreg>> inactive-intervals-for delq ;
+
! Vector of handled live intervals
SYMBOL: handled-intervals
: add-handled ( live-interval -- )
- handled-intervals get push ;
+ [ check-handled ] [ handled-intervals get push ] bi ;
: finished? ( n live-interval -- ? ) end>> swap < ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
-! Start index of current live interval. We ensure that all
-! live intervals added to the unhandled set have a start index
-! strictly greater than ths one. This ensures that we can catch
-! infinite loop situations.
-SYMBOL: progress
-
-: check-progress ( live-interval -- )
- start>> progress get <= [ "No progress" throw ] when ; inline
-
: add-unhandled ( live-interval -- )
- [ check-progress ]
+ [ check-unhandled ]
[ dup start>> unhandled-intervals get heap-push ]
bi ;
: reg-class-assoc ( quot -- assoc )
[ reg-classes ] dip { } map>assoc ; inline
+! Mapping from register classes to spill counts
SYMBOL: spill-counts
-: next-spill-location ( reg-class -- n )
+: next-spill-slot ( reg-class -- n )
spill-counts get [ dup 1 + ] change-at ;
+! Mapping from vregs to spill slots
+SYMBOL: spill-slots
+
+: assign-spill-slot ( vreg -- n )
+ spill-slots get [ reg-class>> next-spill-slot ] cache ;
+
: init-allocator ( registers -- )
registers set
- [ 0 ] reg-class-assoc spill-counts set
<min-heap> unhandled-intervals set
[ V{ } clone ] reg-class-assoc active-intervals set
[ V{ } clone ] reg-class-assoc inactive-intervals set
V{ } clone handled-intervals set
+ [ 0 ] reg-class-assoc spill-counts set
+ H{ } clone spill-slots set
-1 progress set ;
: init-unhandled ( live-intervals -- )
[ [ start>> ] keep ] { } map>assoc
- unhandled-intervals get heap-push-all ;
\ No newline at end of file
+ unhandled-intervals get heap-push-all ;
+
+! A utility used by register-status and spill-status words
+: free-positions ( new -- assoc )
+ vreg>> reg-class>> registers get at [ 1/0. ] H{ } map>assoc ;
+
+: add-use-position ( n reg assoc -- ) [ [ min ] when* ] change-at ;
+
+: register-available? ( new result -- ? )
+ [ end>> ] [ second ] bi* < ; inline
+
+: register-available ( new result -- )
+ first >>reg add-active ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math assocs namespaces sequences heaps
-fry make combinators sets
+fry make combinators sets locals
cpu.architecture
+compiler.cfg
+compiler.cfg.rpo
compiler.cfg.def-use
+compiler.cfg.liveness
compiler.cfg.registers
compiler.cfg.instructions
+compiler.cfg.linear-scan.mapping
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
SYMBOL: pending-intervals
: add-active ( live-interval -- )
- pending-intervals get push ;
+ dup end>> pending-intervals get heap-push ;
! Minheap of live intervals which still need a register allocation
SYMBOL: unhandled-intervals
: init-unhandled ( live-intervals -- )
[ add-unhandled ] each ;
-! Mapping spill slots to vregs
-SYMBOL: spill-slots
+! Mapping from basic blocks to values which are live at the start
+SYMBOL: register-live-ins
-: spill-slots-for ( vreg -- assoc )
- reg-class>> spill-slots get at ;
+! Mapping from basic blocks to values which are live at the end
+SYMBOL: register-live-outs
-ERROR: already-spilled ;
-
-: record-spill ( live-interval -- )
- [ dup spill-to>> ] [ vreg>> spill-slots-for ] bi
- 2dup key? [ already-spilled ] [ set-at ] if ;
-
-: insert-spill ( live-interval -- )
- {
- [ reg>> ]
- [ vreg>> reg-class>> ]
- [ spill-to>> ]
- [ end>> ]
- } cleave f swap \ _spill boa , ;
+: init-assignment ( live-intervals -- )
+ <min-heap> pending-intervals set
+ <min-heap> unhandled-intervals set
+ H{ } clone register-live-ins set
+ H{ } clone register-live-outs set
+ init-unhandled ;
: handle-spill ( live-interval -- )
- dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
+ dup spill-to>> [
+ [ reg>> ] [ spill-to>> <spill-slot> ] [ vreg>> reg-class>> ] tri
+ register->memory
+ ] [ drop ] if ;
-: insert-copy ( live-interval -- )
- {
- [ split-next>> reg>> ]
- [ reg>> ]
- [ vreg>> reg-class>> ]
- [ end>> ]
- } cleave f swap \ _copy boa , ;
+: first-split ( live-interval -- live-interval' )
+ dup split-before>> [ first-split ] [ ] ?if ;
+
+: next-interval ( live-interval -- live-interval' )
+ split-next>> first-split ;
: handle-copy ( live-interval -- )
- dup [ spill-to>> not ] [ split-next>> ] bi and
- [ insert-copy ] [ drop ] if ;
+ dup split-next>> [
+ [ reg>> ] [ next-interval reg>> ] [ vreg>> reg-class>> ] tri
+ register->register
+ ] [ drop ] if ;
+
+: (expire-old-intervals) ( n heap -- )
+ dup heap-empty? [ 2drop ] [
+ 2dup heap-peek nip <= [ 2drop ] [
+ dup heap-pop drop [ handle-spill ] [ handle-copy ] bi
+ (expire-old-intervals)
+ ] if
+ ] if ;
: expire-old-intervals ( n -- )
- [ pending-intervals get ] dip '[
- dup end>> _ <
- [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if
- ] filter-here ;
-
-ERROR: already-reloaded ;
-
-: record-reload ( live-interval -- )
- [ reload-from>> ] [ vreg>> spill-slots-for ] bi
- 2dup key? [ delete-at ] [ already-reloaded ] if ;
+ [
+ pending-intervals get (expire-old-intervals)
+ ] { } make mapping-instructions % ;
: insert-reload ( live-interval -- )
{
[ reg>> ]
[ vreg>> reg-class>> ]
[ reload-from>> ]
- [ end>> ]
+ [ start>> ]
} cleave f swap \ _reload boa , ;
: handle-reload ( live-interval -- )
- dup reload-from>> [ [ record-reload ] [ insert-reload ] bi ] [ drop ] if ;
+ dup reload-from>> [ insert-reload ] [ drop ] if ;
: activate-new-intervals ( n -- )
#! Any live intervals which start on the current instruction
] [ 2drop ] if
] if ;
+: prepare-insn ( n -- )
+ [ expire-old-intervals ] [ activate-new-intervals ] bi ;
+
GENERIC: assign-registers-in-insn ( insn -- )
: register-mapping ( live-intervals -- alist )
- [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
+ [ [ vreg>> ] [ reg>> ] bi ] H{ } map>assoc ;
: all-vregs ( insn -- vregs )
[ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
-: active-intervals ( insn -- intervals )
- insn#>> pending-intervals get [ covers? ] with filter ;
+SYMBOL: check-assignment?
-M: vreg-insn assign-registers-in-insn
- dup [ active-intervals ] [ all-vregs ] bi
- '[ vreg>> _ member? ] filter
- register-mapping
- >>regs drop ;
+ERROR: overlapping-registers intervals ;
+
+: check-assignment ( intervals -- )
+ dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter
+ dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ;
-: compute-live-registers ( insn -- regs )
- [ active-intervals ] [ temp-vregs ] bi
- '[ vreg>> _ memq? not ] filter
- register-mapping ;
+: active-intervals ( n -- intervals )
+ pending-intervals get heap-values [ covers? ] with filter
+ check-assignment? get [ dup check-assignment ] when ;
-: compute-live-spill-slots ( -- spill-slots )
- spill-slots get values [ values ] map concat
- [ [ vreg>> ] [ reload-from>> ] bi ] { } map>assoc ;
+M: vreg-insn assign-registers-in-insn
+ dup [ all-vregs ] [ insn#>> active-intervals register-mapping ] bi
+ extract-keys >>regs drop ;
M: ##gc assign-registers-in-insn
+ ! This works because ##gc is always the first instruction
+ ! in a block.
dup call-next-method
- dup compute-live-registers >>live-registers
- compute-live-spill-slots >>live-spill-slots
+ basic-block get register-live-ins get at >>live-values
drop ;
M: insn assign-registers-in-insn drop ;
-: init-assignment ( live-intervals -- )
- V{ } clone pending-intervals set
- <min-heap> unhandled-intervals set
- [ H{ } clone ] reg-class-assoc spill-slots set
- init-unhandled ;
+: compute-live-spill-slots ( vregs -- assoc )
+ spill-slots get '[ _ at dup [ <spill-slot> ] when ] assoc-map ;
-: assign-registers-in-block ( bb -- )
- [
+: compute-live-registers ( n -- assoc )
+ active-intervals register-mapping ;
+
+ERROR: bad-live-values live-values ;
+
+: check-live-values ( assoc -- assoc )
+ check-assignment? get [
+ dup values [ not ] any? [ bad-live-values ] when
+ ] when ;
+
+: compute-live-values ( vregs n -- assoc )
+ ! If a live vreg is not in active or inactive, then it must have been
+ ! spilled.
+ [ compute-live-spill-slots ] [ compute-live-registers ] bi*
+ assoc-union check-live-values ;
+
+: begin-block ( bb -- )
+ dup basic-block set
+ dup block-from activate-new-intervals
+ [ [ live-in ] [ block-from ] bi compute-live-values ] keep
+ register-live-ins get set-at ;
+
+: end-block ( bb -- )
+ [ [ live-out ] [ block-to ] bi compute-live-values ] keep
+ register-live-outs get set-at ;
+
+ERROR: bad-vreg vreg ;
+
+: vreg-at-start ( vreg bb -- state )
+ register-live-ins get at ?at [ bad-vreg ] unless ;
+
+: vreg-at-end ( vreg bb -- state )
+ register-live-outs get at ?at [ bad-vreg ] unless ;
+
+:: assign-registers-in-block ( bb -- )
+ bb [
[
+ bb begin-block
[
- [
- insn#>>
- [ expire-old-intervals ]
- [ activate-new-intervals ]
- bi
- ]
- [ assign-registers-in-insn ]
- [ , ]
- tri
+ {
+ [ insn#>> 1 - prepare-insn ]
+ [ insn#>> prepare-insn ]
+ [ assign-registers-in-insn ]
+ [ , ]
+ } cleave
] each
+ bb end-block
] V{ } make
] change-instructions drop ;
-: assign-registers ( live-intervals rpo -- )
+: assign-registers ( live-intervals cfg -- )
[ init-assignment ] dip
- [ assign-registers-in-block ] each ;
+ [ assign-registers-in-block ] each-basic-block ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences sets arrays math strings fry
namespaces prettyprint compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation compiler.cfg ;
+compiler.cfg.linear-scan.allocation compiler.cfg assocs ;
IN: compiler.cfg.linear-scan.debugger
: check-assigned ( live-intervals -- )
] [ 1array ] if ;
: check-linear-scan ( live-intervals machine-registers -- )
- [ [ clone ] map ] dip allocate-registers
+ [
+ [ clone ] map dup [ [ vreg>> ] keep ] H{ } map>assoc
+ live-intervals set
+ ] dip allocate-registers
[ split-children ] map concat check-assigned ;
: picture ( uses -- str )
: live-intervals. ( seq -- )
[ interval-picture ] map simple-table. ;
-
-: test-bb ( insns n -- )
- [ <basic-block> swap >>number swap >>instructions ] keep set ;
\ No newline at end of file
IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors locals
-math.order grouping
+math.order grouping strings strings.private classes
cpu.architecture
compiler.cfg
compiler.cfg.optimizer
compiler.cfg.instructions
compiler.cfg.registers
-compiler.cfg.liveness
compiler.cfg.predecessors
compiler.cfg.rpo
compiler.cfg.linearization
compiler.cfg.debugger
+compiler.cfg.comparisons
compiler.cfg.linear-scan
+compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.allocation.spilling
-compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.debugger ;
+FROM: compiler.cfg.linear-scan.assignment => check-assignment? ;
+
check-allocation? on
+check-assignment? on
+check-numbering? on
[
{ T{ live-range f 1 10 } T{ live-range f 15 15 } }
{ T{ live-range f 0 5 } } 0 split-ranges
] unit-test
-[ 7 ] [
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
- { start 0 }
- { end 10 }
- { uses V{ 0 1 3 7 10 } }
- }
- 4 [ >= ] find-use
-] unit-test
-
-[ 4 ] [
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
- { start 0 }
- { end 10 }
- { uses V{ 0 1 3 4 10 } }
- }
- 4 [ >= ] find-use
-] unit-test
-
-[ f ] [
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 2 } } }
- { start 0 }
- { end 10 }
- { uses V{ 0 1 3 4 10 } }
- }
- 100 [ >= ] find-use
-] unit-test
-
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
- { end 1 }
+ { end 2 }
{ uses V{ 0 1 } }
- { ranges V{ T{ live-range f 0 1 } } }
+ { ranges V{ T{ live-range f 0 2 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
- { end 0 }
+ { end 1 }
{ uses V{ 0 } }
- { ranges V{ T{ live-range f 0 0 } } }
+ { ranges V{ T{ live-range f 0 1 } } }
}
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
} 0 split-for-spill [ f >>split-next ] bi@
] unit-test
+[
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 1 }
+ { uses V{ 0 } }
+ { ranges V{ T{ live-range f 0 1 } } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 20 }
+ { end 30 }
+ { uses V{ 20 30 } }
+ { ranges V{ T{ live-range f 20 30 } } }
+ }
+] [
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { start 0 }
+ { end 30 }
+ { uses V{ 0 20 30 } }
+ { ranges V{ T{ live-range f 0 8 } T{ live-range f 10 18 } T{ live-range f 20 30 } } }
+ } 10 split-for-spill [ f >>split-next ] bi@
+] unit-test
+
[
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
- { end 5 }
- { uses V{ 5 } }
- { ranges V{ T{ live-range f 5 5 } } }
+ { end 10 }
+ { uses V{ 5 10 } }
+ { ranges V{ T{ live-range f 5 10 } } }
}
] [
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 0 }
- { end 5 }
- { uses V{ 0 1 5 } }
- { ranges V{ T{ live-range f 0 5 } } }
- } 5 split-before-use [ f >>split-next ] bi@
+ { end 10 }
+ { uses V{ 0 1 4 5 10 } }
+ { ranges V{ T{ live-range f 0 10 } } }
+ } 4 split-to-fit [ f >>split-next ] bi@
] unit-test
[
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 3 }
- { end 10 }
- { uses V{ 3 10 } }
- }
-] [
{
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 1 }
- { end 15 }
- { uses V{ 1 3 7 10 15 } }
- }
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 3 }
- { end 8 }
- { uses V{ 3 4 8 } }
- }
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 3 }
- { end 10 }
- { uses V{ 3 10 } }
- }
+ 3
+ 10
}
+] [
+ H{
+ { int-regs
+ V{
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { reg 1 }
+ { start 1 }
+ { end 15 }
+ { uses V{ 1 3 7 10 15 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { reg 2 }
+ { start 3 }
+ { end 8 }
+ { uses V{ 3 4 8 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 3 } } }
+ { reg 3 }
+ { start 3 }
+ { end 10 }
+ { uses V{ 3 10 } }
+ }
+ }
+ }
+ } active-intervals set
+ H{ } inactive-intervals set
T{ live-interval
{ vreg T{ vreg { reg-class int-regs } { n 1 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
}
- interval-to-spill
-] unit-test
-
-[ t ] [
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 5 }
- { end 15 }
- { uses V{ 5 10 15 } }
- }
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 1 }
- { end 20 }
- { uses V{ 1 20 } }
- }
- spill-existing?
+ spill-status
] unit-test
-[ f ] [
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 5 }
- { end 15 }
- { uses V{ 5 10 15 } }
- }
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 1 }
- { end 20 }
- { uses V{ 1 7 20 } }
+[
+ {
+ 1
+ 1/0.
}
- spill-existing?
-] unit-test
-
-[ t ] [
+] [
+ H{
+ { int-regs
+ V{
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { reg 1 }
+ { start 1 }
+ { end 15 }
+ { uses V{ 1 } }
+ }
+ T{ live-interval
+ { vreg T{ vreg { reg-class int-regs } { n 2 } } }
+ { reg 2 }
+ { start 3 }
+ { end 8 }
+ { uses V{ 3 8 } }
+ }
+ }
+ }
+ } active-intervals set
+ H{ } inactive-intervals set
T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
+ { vreg T{ vreg { reg-class int-regs } { n 3 } } }
{ start 5 }
{ end 5 }
{ uses V{ 5 } }
}
- T{ live-interval
- { vreg T{ vreg { reg-class int-regs } { n 1 } } }
- { start 1 }
- { end 20 }
- { uses V{ 1 7 20 } }
- }
- spill-existing?
+ spill-status
] unit-test
[ ] [
[
\ live-interval new
swap int-regs swap vreg boa >>vreg
- max-uses get random 2 max [ not-taken ] replicate natural-sort
+ max-uses get random 2 max [ not-taken 2 * ] replicate natural-sort
[ >>uses ] [ first >>start ] bi
dup uses>> last >>end
dup [ start>> ] [ end>> ] bi <live-range> 1vector >>ranges
allocate-registers drop
] unit-test
-! Spill slot liveness was computed incorrectly, leading to a FEP
-! early in bootstrap on x86-32
-[ t t ] [
- [
- H{ } clone live-ins set
- H{ } clone live-outs set
- H{ } clone phi-live-ins set
- T{ basic-block
- { id 12345 }
- { instructions
- V{
- T{ ##gc f V int-regs 6 V int-regs 7 }
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##peek f V int-regs 1 D 1 }
- T{ ##peek f V int-regs 2 D 2 }
- T{ ##peek f V int-regs 3 D 3 }
- T{ ##peek f V int-regs 4 D 4 }
- T{ ##peek f V int-regs 5 D 5 }
- T{ ##replace f V int-regs 0 D 1 }
- T{ ##replace f V int-regs 1 D 2 }
- T{ ##replace f V int-regs 2 D 3 }
- T{ ##replace f V int-regs 3 D 4 }
- T{ ##replace f V int-regs 4 D 5 }
- T{ ##replace f V int-regs 5 D 0 }
- }
- }
- } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan)
- instructions>> first
- [ live-spill-slots>> empty? ]
- [ live-registers>> empty? ] bi
- ] with-scope
-] unit-test
-
[ f ] [
T{ live-range f 0 10 }
T{ live-range f 20 30 }
intersect-live-ranges
] unit-test
+[ f ] [
+ {
+ T{ live-range f 0 10 }
+ T{ live-range f 20 30 }
+ T{ live-range f 40 50 }
+ }
+ {
+ T{ live-range f 11 15 }
+ T{ live-range f 31 36 }
+ T{ live-range f 51 55 }
+ }
+ intersect-live-ranges
+] unit-test
+
[ 5 ] [
T{ live-interval
{ start 0 }
relevant-ranges intersect-live-ranges
] unit-test
+! register-status had problems because it used map>assoc where the sequence
+! had multiple keys
+[ { 0 10 } ] [
+ H{ { int-regs { 0 1 } } } registers set
+ H{
+ { int-regs
+ {
+ T{ live-interval
+ { vreg V int-regs 1 }
+ { start 0 }
+ { end 20 }
+ { reg 0 }
+ { ranges V{ T{ live-range f 0 2 } T{ live-range f 10 20 } } }
+ { uses V{ 0 2 10 20 } }
+ }
+
+ T{ live-interval
+ { vreg V int-regs 2 }
+ { start 4 }
+ { end 40 }
+ { reg 0 }
+ { ranges V{ T{ live-range f 4 6 } T{ live-range f 30 40 } } }
+ { uses V{ 4 6 30 40 } }
+ }
+ }
+ }
+ } inactive-intervals set
+ H{
+ { int-regs
+ {
+ T{ live-interval
+ { vreg V int-regs 3 }
+ { start 0 }
+ { end 40 }
+ { reg 1 }
+ { ranges V{ T{ live-range f 0 40 } } }
+ { uses V{ 0 40 } }
+ }
+ }
+ }
+ } active-intervals set
+
+ T{ live-interval
+ { vreg V int-regs 4 }
+ { start 8 }
+ { end 10 }
+ { ranges V{ T{ live-range f 8 10 } } }
+ { uses V{ 8 10 } }
+ }
+ register-status
+] unit-test
+
! Bug in live spill slots calculation
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
SYMBOL: linear-scan-result
:: test-linear-scan-on-cfg ( regs -- )
- [ ] [
+ [
cfg new 0 get >>entry
compute-predecessors
- compute-liveness
- dup reverse-post-order
- { { int-regs regs } } (linear-scan)
+ dup { { int-regs regs } } (linear-scan)
+ cfg-changed
flatten-cfg 1array mr.
- ] unit-test ;
+ ] with-scope ;
! This test has a critical edge -- do we care about these?
-! { 1 2 } test-linear-scan-on-cfg
+! [ { 1 2 } test-linear-scan-on-cfg ] unit-test
! Bug in inactive interval handling
! [ rot dup [ -rot ] when ]
T{ ##return }
} 4 test-bb
-: test-diamond ( -- )
- 1 get 1vector 0 get (>>successors)
- 2 get 3 get V{ } 2sequence 1 get (>>successors)
- 4 get 1vector 2 get (>>successors)
- 4 get 1vector 3 get (>>successors) ;
-
test-diamond
-{ 1 2 3 4 } test-linear-scan-on-cfg
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
! Similar to the above
! [ swap dup [ rot ] when ]
test-diamond
-{ 1 2 3 4 } test-linear-scan-on-cfg
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
! compute-live-registers was inaccurate since it didn't take
! lifetime holes into account
test-diamond
-{ 1 2 3 4 } test-linear-scan-on-cfg
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
! Inactive interval handling: splitting active interval
! if it fits in lifetime hole only partially
test-diamond
-{ 1 2 } test-linear-scan-on-cfg
-
-USING: classes ;
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
[ ] [
1 get instructions>> first regs>> V int-regs 0 swap at
2 get instructions>> first regs>> V int-regs 1 swap at assert=
] unit-test
-[ _copy ] [ 3 get instructions>> second class ] unit-test
+! Not until splitting is finished
+! [ _copy ] [ 3 get instructions>> second class ] unit-test
! Resolve pass; make sure the spilling is done correctly
V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb
test-diamond
-{ 1 2 } test-linear-scan-on-cfg
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-[ _spill ] [ 2 get instructions>> first class ] unit-test
+[ _spill ] [ 2 get successors>> first instructions>> first class ] unit-test
[ _spill ] [ 3 get instructions>> second class ] unit-test
-[ _reload ] [ 4 get instructions>> first class ] unit-test
\ No newline at end of file
+[ f ] [ 3 get instructions>> [ _reload? ] any? ] unit-test
+
+[ _reload ] [ 4 get instructions>> first class ] unit-test
+
+! Resolve pass
+V{
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+} 1 test-bb
+
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##peek f V int-regs 2 D 0 }
+ T{ ##replace f V int-regs 1 D 0 }
+ T{ ##replace f V int-regs 2 D 0 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##compare-imm-branch f V int-regs 1 5 cc= }
+} 4 test-bb
+
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##return }
+} 5 test-bb
+
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##return }
+} 6 test-bb
+
+0 get 1 get V{ } 1sequence >>successors drop
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+2 get 4 get V{ } 1sequence >>successors drop
+3 get 4 get V{ } 1sequence >>successors drop
+4 get 5 get 6 get V{ } 2sequence >>successors drop
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+[ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test
+
+[ t ] [ 3 get predecessors>> first instructions>> [ _spill? ] any? ] unit-test
+
+[ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test
+
+! A more complicated failure case with resolve that came up after the above
+! got fixed
+V{ T{ ##branch } } 0 test-bb
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##peek f V int-regs 3 D 3 }
+ T{ ##peek f V int-regs 4 D 0 }
+ T{ ##branch }
+} 1 test-bb
+V{ T{ ##branch } } 2 test-bb
+V{ T{ ##branch } } 3 test-bb
+V{
+
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 3 D 3 }
+ T{ ##replace f V int-regs 4 D 4 }
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##branch }
+} 4 test-bb
+V{ T{ ##replace f V int-regs 0 D 0 } T{ ##branch } } 5 test-bb
+V{ T{ ##return } } 6 test-bb
+V{ T{ ##branch } } 7 test-bb
+V{
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 3 D 3 }
+ T{ ##peek f V int-regs 5 D 1 }
+ T{ ##peek f V int-regs 6 D 2 }
+ T{ ##peek f V int-regs 7 D 3 }
+ T{ ##peek f V int-regs 8 D 4 }
+ T{ ##replace f V int-regs 5 D 1 }
+ T{ ##replace f V int-regs 6 D 2 }
+ T{ ##replace f V int-regs 7 D 3 }
+ T{ ##replace f V int-regs 8 D 4 }
+ T{ ##branch }
+} 8 test-bb
+V{
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 3 D 3 }
+ T{ ##return }
+} 9 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 7 get V{ } 2sequence >>successors drop
+7 get 8 get 1vector >>successors drop
+8 get 9 get 1vector >>successors drop
+2 get 3 get 5 get V{ } 2sequence >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 9 get 1vector >>successors drop
+5 get 6 get 1vector >>successors drop
+
+[ ] [ { 1 2 3 4 } test-linear-scan-on-cfg ] unit-test
+
+[ _spill ] [ 1 get instructions>> second class ] unit-test
+[ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test
+[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> ] map ] unit-test
+[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test
+
+! Resolve pass should insert this
+[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test
+
+! Some random bug
+V{
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##peek f V int-regs 3 D 0 }
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+} 0 test-bb
+
+V{ T{ ##branch } } 1 test-bb
+
+V{
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 3 D 3 }
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 0 D 3 }
+ T{ ##branch }
+} 2 test-bb
+
+V{ T{ ##branch } } 3 test-bb
+
+V{
+ T{ ##return }
+} 4 test-bb
+
+test-diamond
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+! Spilling an interval immediately after its activated;
+! and the interval does not have a use at the activation point
+V{
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+} 0 test-bb
+
+V{ T{ ##branch } } 1 test-bb
+
+V{
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##replace f V int-regs 2 D 2 }
+ T{ ##branch }
+} 3 test-bb
+
+V{ T{ ##branch } } 4 test-bb
+
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##return }
+} 5 test-bb
+
+1 get 1vector 0 get (>>successors)
+2 get 4 get V{ } 2sequence 1 get (>>successors)
+5 get 1vector 4 get (>>successors)
+3 get 1vector 2 get (>>successors)
+5 get 1vector 3 get (>>successors)
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+! Reduction of push-all regression, x86-32
+V{ T{ ##prologue } T{ ##branch } } 0 test-bb
+
+V{
+ T{ ##load-immediate { dst V int-regs 61 } }
+ T{ ##peek { dst V int-regs 62 } { loc D 0 } }
+ T{ ##peek { dst V int-regs 64 } { loc D 1 } }
+ T{ ##slot-imm
+ { dst V int-regs 69 }
+ { obj V int-regs 64 }
+ { slot 1 }
+ { tag 2 }
+ }
+ T{ ##copy { dst V int-regs 79 } { src V int-regs 69 } }
+ T{ ##slot-imm
+ { dst V int-regs 85 }
+ { obj V int-regs 62 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##compare-branch
+ { src1 V int-regs 69 }
+ { src2 V int-regs 85 }
+ { cc cc> }
+ }
+} 1 test-bb
+
+V{
+ T{ ##slot-imm
+ { dst V int-regs 97 }
+ { obj V int-regs 62 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##replace { src V int-regs 79 } { loc D 3 } }
+ T{ ##replace { src V int-regs 62 } { loc D 4 } }
+ T{ ##replace { src V int-regs 79 } { loc D 1 } }
+ T{ ##replace { src V int-regs 62 } { loc D 2 } }
+ T{ ##replace { src V int-regs 61 } { loc D 5 } }
+ T{ ##replace { src V int-regs 62 } { loc R 0 } }
+ T{ ##replace { src V int-regs 69 } { loc R 1 } }
+ T{ ##replace { src V int-regs 97 } { loc D 0 } }
+ T{ ##call { word resize-array } }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 98 } { loc R 0 } }
+ T{ ##peek { dst V int-regs 100 } { loc D 0 } }
+ T{ ##set-slot-imm
+ { src V int-regs 100 }
+ { obj V int-regs 98 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##peek { dst V int-regs 108 } { loc D 2 } }
+ T{ ##peek { dst V int-regs 110 } { loc D 3 } }
+ T{ ##peek { dst V int-regs 112 } { loc D 0 } }
+ T{ ##peek { dst V int-regs 114 } { loc D 1 } }
+ T{ ##peek { dst V int-regs 116 } { loc D 4 } }
+ T{ ##peek { dst V int-regs 119 } { loc R 0 } }
+ T{ ##copy { dst V int-regs 109 } { src V int-regs 108 } }
+ T{ ##copy { dst V int-regs 111 } { src V int-regs 110 } }
+ T{ ##copy { dst V int-regs 113 } { src V int-regs 112 } }
+ T{ ##copy { dst V int-regs 115 } { src V int-regs 114 } }
+ T{ ##copy { dst V int-regs 117 } { src V int-regs 116 } }
+ T{ ##copy { dst V int-regs 120 } { src V int-regs 119 } }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##copy { dst V int-regs 109 } { src V int-regs 62 } }
+ T{ ##copy { dst V int-regs 111 } { src V int-regs 61 } }
+ T{ ##copy { dst V int-regs 113 } { src V int-regs 62 } }
+ T{ ##copy { dst V int-regs 115 } { src V int-regs 79 } }
+ T{ ##copy { dst V int-regs 117 } { src V int-regs 64 } }
+ T{ ##copy { dst V int-regs 120 } { src V int-regs 69 } }
+ T{ ##branch }
+} 4 test-bb
+
+V{
+ T{ ##replace { src V int-regs 120 } { loc D 0 } }
+ T{ ##replace { src V int-regs 109 } { loc D 3 } }
+ T{ ##replace { src V int-regs 111 } { loc D 4 } }
+ T{ ##replace { src V int-regs 113 } { loc D 1 } }
+ T{ ##replace { src V int-regs 115 } { loc D 2 } }
+ T{ ##replace { src V int-regs 117 } { loc D 5 } }
+ T{ ##epilogue }
+ T{ ##return }
+} 5 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 4 get V{ } 2sequence >>successors drop
+2 get 3 get 1vector >>successors drop
+3 get 5 get 1vector >>successors drop
+4 get 5 get 1vector >>successors drop
+
+[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
+
+! Another reduction of push-all
+V{ T{ ##prologue } T{ ##branch } } 0 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 85 } { loc D 0 } }
+ T{ ##slot-imm
+ { dst V int-regs 89 }
+ { obj V int-regs 85 }
+ { slot 3 }
+ { tag 7 }
+ }
+ T{ ##peek { dst V int-regs 91 } { loc D 1 } }
+ T{ ##slot-imm
+ { dst V int-regs 96 }
+ { obj V int-regs 91 }
+ { slot 1 }
+ { tag 2 }
+ }
+ T{ ##add
+ { dst V int-regs 109 }
+ { src1 V int-regs 89 }
+ { src2 V int-regs 96 }
+ }
+ T{ ##slot-imm
+ { dst V int-regs 115 }
+ { obj V int-regs 85 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##slot-imm
+ { dst V int-regs 118 }
+ { obj V int-regs 115 }
+ { slot 1 }
+ { tag 2 }
+ }
+ T{ ##compare-branch
+ { src1 V int-regs 109 }
+ { src2 V int-regs 118 }
+ { cc cc> }
+ }
+} 1 test-bb
+
+V{
+ T{ ##add-imm
+ { dst V int-regs 128 }
+ { src1 V int-regs 109 }
+ { src2 8 }
+ }
+ T{ ##load-immediate { dst V int-regs 129 } { val 24 } }
+ T{ ##inc-d { n 4 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##replace { src V int-regs 109 } { loc D 2 } }
+ T{ ##replace { src V int-regs 85 } { loc D 3 } }
+ T{ ##replace { src V int-regs 128 } { loc D 0 } }
+ T{ ##replace { src V int-regs 85 } { loc D 1 } }
+ T{ ##replace { src V int-regs 89 } { loc D 4 } }
+ T{ ##replace { src V int-regs 96 } { loc R 0 } }
+ T{ ##replace { src V int-regs 129 } { loc R 0 } }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 134 } { loc D 1 } }
+ T{ ##slot-imm
+ { dst V int-regs 140 }
+ { obj V int-regs 134 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##inc-d { n 1 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##replace { src V int-regs 140 } { loc D 0 } }
+ T{ ##replace { src V int-regs 134 } { loc R 0 } }
+ T{ ##call { word resize-array } }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 141 } { loc R 0 } }
+ T{ ##peek { dst V int-regs 143 } { loc D 0 } }
+ T{ ##set-slot-imm
+ { src V int-regs 143 }
+ { obj V int-regs 141 }
+ { slot 2 }
+ { tag 7 }
+ }
+ T{ ##write-barrier
+ { src V int-regs 141 }
+ { card# V int-regs 145 }
+ { table V int-regs 146 }
+ }
+ T{ ##inc-d { n -1 } }
+ T{ ##inc-r { n -1 } }
+ T{ ##peek { dst V int-regs 156 } { loc D 2 } }
+ T{ ##peek { dst V int-regs 158 } { loc D 3 } }
+ T{ ##peek { dst V int-regs 160 } { loc D 0 } }
+ T{ ##peek { dst V int-regs 162 } { loc D 1 } }
+ T{ ##peek { dst V int-regs 164 } { loc D 4 } }
+ T{ ##peek { dst V int-regs 167 } { loc R 0 } }
+ T{ ##copy { dst V int-regs 157 } { src V int-regs 156 } }
+ T{ ##copy { dst V int-regs 159 } { src V int-regs 158 } }
+ T{ ##copy { dst V int-regs 161 } { src V int-regs 160 } }
+ T{ ##copy { dst V int-regs 163 } { src V int-regs 162 } }
+ T{ ##copy { dst V int-regs 165 } { src V int-regs 164 } }
+ T{ ##copy { dst V int-regs 168 } { src V int-regs 167 } }
+ T{ ##branch }
+} 4 test-bb
+
+V{
+ T{ ##inc-d { n 3 } }
+ T{ ##inc-r { n 1 } }
+ T{ ##copy { dst V int-regs 157 } { src V int-regs 85 } }
+ T{ ##copy { dst V int-regs 159 } { src V int-regs 89 } }
+ T{ ##copy { dst V int-regs 161 } { src V int-regs 85 } }
+ T{ ##copy { dst V int-regs 163 } { src V int-regs 109 } }
+ T{ ##copy { dst V int-regs 165 } { src V int-regs 91 } }
+ T{ ##copy { dst V int-regs 168 } { src V int-regs 96 } }
+ T{ ##branch }
+} 5 test-bb
+
+V{
+ T{ ##set-slot-imm
+ { src V int-regs 163 }
+ { obj V int-regs 161 }
+ { slot 3 }
+ { tag 7 }
+ }
+ T{ ##inc-d { n 1 } }
+ T{ ##inc-r { n -1 } }
+ T{ ##replace { src V int-regs 168 } { loc D 0 } }
+ T{ ##replace { src V int-regs 157 } { loc D 3 } }
+ T{ ##replace { src V int-regs 159 } { loc D 4 } }
+ T{ ##replace { src V int-regs 161 } { loc D 1 } }
+ T{ ##replace { src V int-regs 163 } { loc D 2 } }
+ T{ ##replace { src V int-regs 165 } { loc D 5 } }
+ T{ ##epilogue }
+ T{ ##return }
+} 6 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 5 get V{ } 2sequence >>successors drop
+2 get 3 get 1vector >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 6 get 1vector >>successors drop
+5 get 6 get 1vector >>successors drop
+
+[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test
+
+! Fencepost error in assignment pass
+V{ T{ ##branch } } 0 test-bb
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+} 1 test-bb
+
+V{ T{ ##branch } } 2 test-bb
+
+V{
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##peek f V int-regs 2 D 0 }
+ T{ ##replace f V int-regs 1 D 0 }
+ T{ ##replace f V int-regs 2 D 0 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##return }
+} 4 test-bb
+
+test-diamond
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test
+
+[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
+
+[ 1 ] [ 3 get predecessors>> first instructions>> [ _spill? ] count ] unit-test
+
+[ 1 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
+
+! Another test case for fencepost error in assignment pass
+V{ T{ ##branch } } 0 test-bb
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-imm-branch f V int-regs 0 5 cc= }
+} 1 test-bb
+
+V{
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##peek f V int-regs 2 D 0 }
+ T{ ##replace f V int-regs 1 D 0 }
+ T{ ##replace f V int-regs 2 D 0 }
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##return }
+} 4 test-bb
+
+test-diamond
+
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
+
+[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test
+
+[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test
+
+[ 1 ] [ 2 get instructions>> [ _reload? ] count ] unit-test
+
+[ 0 ] [ 3 get instructions>> [ _spill? ] count ] unit-test
+
+[ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test
+
+! GC check tests
+
+! Spill slot liveness was computed incorrectly, leading to a FEP
+! early in bootstrap on x86-32
+[ t ] [
+ [
+ T{ basic-block
+ { id 12345 }
+ { instructions
+ V{
+ T{ ##gc f V int-regs 6 V int-regs 7 }
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 2 D 2 }
+ T{ ##peek f V int-regs 3 D 3 }
+ T{ ##peek f V int-regs 4 D 4 }
+ T{ ##peek f V int-regs 5 D 5 }
+ T{ ##replace f V int-regs 0 D 1 }
+ T{ ##replace f V int-regs 1 D 2 }
+ T{ ##replace f V int-regs 2 D 3 }
+ T{ ##replace f V int-regs 3 D 4 }
+ T{ ##replace f V int-regs 4 D 5 }
+ T{ ##replace f V int-regs 5 D 0 }
+ }
+ }
+ } cfg new over >>entry
+ { { int-regs V{ 0 1 2 3 } } } (linear-scan)
+ instructions>> first
+ live-values>> assoc-empty?
+ ] with-scope
+] unit-test
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##gc f V int-regs 2 V int-regs 3 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##return }
+} 2 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 1vector >>successors drop
+
+[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
+
+[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test
+
+
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##compare-imm-branch f V int-regs 1 5 cc= }
+} 0 test-bb
+
+V{
+ T{ ##gc f V int-regs 2 V int-regs 3 }
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##return }
+} 1 test-bb
+
+V{
+ T{ ##return }
+} 2 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+
+[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test
+
+[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test
cpu.architecture
compiler.cfg
compiler.cfg.rpo
+compiler.cfg.liveness
compiler.cfg.instructions
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.assignment
-compiler.cfg.linear-scan.resolve ;
+compiler.cfg.linear-scan.resolve
+compiler.cfg.linear-scan.mapping ;
IN: compiler.cfg.linear-scan
! References:
! by Omri Traub, Glenn Holloway, Michael D. Smith
! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.34.8435
-:: (linear-scan) ( rpo machine-registers -- )
- rpo number-instructions
- rpo compute-live-intervals machine-registers allocate-registers
- rpo assign-registers
- rpo resolve-data-flow ;
+:: (linear-scan) ( cfg machine-registers -- )
+ cfg compute-live-sets
+ cfg number-instructions
+ cfg compute-live-intervals machine-registers allocate-registers
+ cfg assign-registers
+ cfg resolve-data-flow
+ cfg check-numbering ;
: linear-scan ( cfg -- cfg' )
[
- dup reverse-post-order machine-registers (linear-scan)
+ init-mapping
+ dup machine-registers (linear-scan)
spill-counts get >>spill-counts
+ cfg-changed
] with-scope ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs accessors sequences math math.order fry
-binary-search combinators compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ;
+combinators binary-search compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.rpo
+compiler.cfg ;
IN: compiler.cfg.linear-scan.live-intervals
TUPLE: live-range from to ;
start end ranges uses
copy-from ;
-: covers? ( insn# live-interval -- ? )
- ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ;
+GENERIC: covers? ( insn# obj -- ? )
-: child-interval-at ( insn# interval -- interval' )
- dup split-after>> [
- 2dup split-after>> start>> <
- [ split-before>> ] [ split-after>> ] if
- child-interval-at
- ] [ nip ] if ;
+M: f covers? 2drop f ;
+M: live-range covers? [ from>> ] [ to>> ] bi between? ;
+
+M: live-interval covers? ( insn# live-interval -- ? )
+ ranges>>
+ dup length 4 <= [
+ [ covers? ] with any?
+ ] [
+ [ drop ] [ [ from>> <=> ] with search nip ] 2bi
+ covers?
+ ] if ;
+
ERROR: dead-value-error vreg ;
: shorten-range ( n live-interval -- )
V{ } clone >>ranges
swap >>vreg ;
-: block-from ( bb -- n ) instructions>> first insn#>> ;
+: block-from ( bb -- n ) instructions>> first insn#>> 1 - ;
: block-to ( bb -- n ) instructions>> last insn#>> ;
dup ranges>> [ first from>> ] [ last to>> ] bi
[ >>start ] [ >>end ] bi* drop ;
-: check-start/end ( live-interval -- )
- [ [ start>> ] [ uses>> first ] bi assert= ]
- [ [ end>> ] [ uses>> last ] bi assert= ]
- bi ;
+ERROR: bad-live-interval live-interval ;
+
+: check-start ( live-interval -- )
+ dup start>> -1 = [ bad-live-interval ] [ drop ] if ;
: finish-live-intervals ( live-intervals -- )
! Since live intervals are computed in a backward order, we have
[ ranges>> reverse-here ]
[ uses>> reverse-here ]
[ compute-start/end ]
- [ check-start/end ]
+ [ check-start ]
} cleave
] each ;
-: compute-live-intervals ( rpo -- live-intervals )
+: compute-live-intervals ( cfg -- live-intervals )
H{ } clone [
live-intervals set
- <reversed> [ compute-live-intervals-step ] each
+ post-order [ compute-live-intervals-step ] each
] keep values dup finish-live-intervals ;
-: relevant-ranges ( new inactive -- new' inactive' )
- ! Slice off all ranges of 'inactive' that precede the start of 'new'
+: relevant-ranges ( interval1 interval2 -- ranges1 ranges2 )
[ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
: intersect-live-range ( range1 range2 -- n/f )
: intersect-live-ranges ( ranges1 ranges2 -- n )
{
- { [ over empty? ] [ 2drop 1/0. ] }
- { [ dup empty? ] [ 2drop 1/0. ] }
+ { [ over empty? ] [ 2drop f ] }
+ { [ dup empty? ] [ 2drop f ] }
[
2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
drop
] if
]
} cond ;
+
+: intervals-intersect? ( interval1 interval2 -- ? )
+ relevant-ranges intersect-live-ranges >boolean ; inline
\ No newline at end of file
--- /dev/null
+USING: compiler.cfg.instructions
+compiler.cfg.linear-scan.allocation.state
+compiler.cfg.linear-scan.mapping cpu.architecture kernel
+namespaces tools.test ;
+IN: compiler.cfg.linear-scan.mapping.tests
+
+H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
+init-mapping
+
+[
+ {
+ T{ _copy { dst 5 } { src 4 } { class int-regs } }
+ T{ _spill { src 1 } { class int-regs } { n 10 } }
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _reload { dst 0 } { class int-regs } { n 10 } }
+ T{ _spill { src 1 } { class float-regs } { n 20 } }
+ T{ _copy { dst 1 } { src 0 } { class float-regs } }
+ T{ _reload { dst 0 } { class float-regs } { n 20 } }
+ }
+] [
+ {
+ T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ register->register { from 1 } { to 0 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 1 } { reg-class float-regs } }
+ T{ register->register { from 1 } { to 0 } { reg-class float-regs } }
+ T{ register->register { from 4 } { to 5 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
+
+[
+ {
+ T{ _spill { src 2 } { class int-regs } { n 10 } }
+ T{ _copy { dst 2 } { src 1 } { class int-regs } }
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _reload { dst 0 } { class int-regs } { n 10 } }
+ }
+] [
+ {
+ T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+ T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
+
+[
+ {
+ T{ _spill { src 0 } { class int-regs } { n 10 } }
+ T{ _copy { dst 0 } { src 2 } { class int-regs } }
+ T{ _copy { dst 2 } { src 1 } { class int-regs } }
+ T{ _reload { dst 1 } { class int-regs } { n 10 } }
+ }
+] [
+ {
+ T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+ T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
+
+[
+ {
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _copy { dst 2 } { src 0 } { class int-regs } }
+ }
+] [
+ {
+ T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
+
+[
+ { }
+] [
+ {
+ T{ register->register { from 4 } { to 4 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
+
+[
+ {
+ T{ _spill { src 3 } { class int-regs } { n 4 } }
+ T{ _reload { dst 2 } { class int-regs } { n 1 } }
+ }
+] [
+ {
+ T{ register->memory { from 3 } { to T{ spill-slot f 4 } } { reg-class int-regs } }
+ T{ memory->register { from T{ spill-slot f 1 } } { to 2 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
+
+
+[
+ {
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _copy { dst 2 } { src 0 } { class int-regs } }
+ T{ _copy { dst 0 } { src 3 } { class int-regs } }
+ }
+] [
+ {
+ T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
+
+[
+ {
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _copy { dst 2 } { src 0 } { class int-regs } }
+ T{ _spill { src 4 } { class int-regs } { n 10 } }
+ T{ _copy { dst 4 } { src 0 } { class int-regs } }
+ T{ _copy { dst 0 } { src 3 } { class int-regs } }
+ T{ _reload { dst 3 } { class int-regs } { n 10 } }
+ }
+] [
+ {
+ T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+ T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+ T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
+
+[
+ {
+ T{ _copy { dst 2 } { src 0 } { class int-regs } }
+ T{ _copy { dst 9 } { src 1 } { class int-regs } }
+ T{ _copy { dst 1 } { src 0 } { class int-regs } }
+ T{ _spill { src 4 } { class int-regs } { n 10 } }
+ T{ _copy { dst 4 } { src 0 } { class int-regs } }
+ T{ _copy { dst 0 } { src 3 } { class int-regs } }
+ T{ _reload { dst 3 } { class int-regs } { n 10 } }
+ }
+] [
+ {
+ T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+ T{ register->register { from 1 } { to 9 } { reg-class int-regs } }
+ T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
+ T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
+ T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
+ } mapping-instructions
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs classes.parser classes.tuple
+combinators compiler.cfg.instructions
+compiler.cfg.linear-scan.allocation.state fry hashtables kernel
+locals make namespaces parser sequences sets words ;
+IN: compiler.cfg.linear-scan.mapping
+
+SYMBOL: spill-temps
+
+: spill-temp ( reg-class -- n )
+ spill-temps get [ next-spill-slot ] cache ;
+
+<<
+
+TUPLE: operation from to reg-class ;
+
+SYNTAX: OPERATION:
+ CREATE-CLASS dup save-location
+ [ operation { } define-tuple-class ]
+ [ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ;
+
+>>
+
+OPERATION: register->memory
+OPERATION: memory->register
+OPERATION: register->register
+
+! This should never come up because of how spill slots are assigned,
+! so make it an error.
+: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ;
+
+GENERIC: >insn ( operation -- )
+
+M: register->memory >insn
+ [ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ;
+
+M: memory->register >insn
+ [ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ;
+
+M: register->register >insn
+ [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
+
+SYMBOL: froms
+SYMBOL: tos
+
+SINGLETONS: memory register ;
+
+: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
+
+: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
+
+: from-reg ( operation -- seq )
+ [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
+
+: to-reg ( operation -- seq )
+ [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
+
+: start? ( operations -- pair )
+ from-reg tos get key? not ;
+
+: independent-assignment? ( operations -- pair )
+ to-reg froms get key? not ;
+
+: set-tos/froms ( operations -- )
+ [ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
+ [ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
+ bi ;
+
+:: (trace-chain) ( obj hashtable -- )
+ obj to-reg froms get at* [
+ dup ,
+ obj over hashtable clone [ maybe-set-at ] keep swap
+ [ (trace-chain) ] [ 2drop ] if
+ ] [
+ drop
+ ] if ;
+
+: trace-chain ( obj -- seq )
+ [
+ dup ,
+ dup dup associate (trace-chain)
+ ] { } make prune reverse ;
+
+: trace-chains ( seq -- seq' )
+ [ trace-chain ] map concat ;
+
+ERROR: resolve-error ;
+
+: split-cycle ( operations -- chain spilled-operation )
+ unclip [
+ [ set-tos/froms ]
+ [
+ [ start? ] find nip
+ [ resolve-error ] unless* trace-chain
+ ] bi
+ ] dip ;
+
+: break-cycle-n ( operations -- operations' )
+ split-cycle [
+ [ from>> ]
+ [ reg-class>> spill-temp <spill-slot> ]
+ [ reg-class>> ]
+ tri \ register->memory boa
+ ] [
+ [ reg-class>> spill-temp <spill-slot> ]
+ [ to>> ]
+ [ reg-class>> ]
+ tri \ memory->register boa
+ ] bi [ 1array ] bi@ surround ;
+
+: break-cycle ( operations -- operations' )
+ dup length {
+ { 1 [ ] }
+ [ drop break-cycle-n ]
+ } case ;
+
+: (group-cycles) ( seq -- )
+ [
+ dup set-tos/froms
+ unclip trace-chain
+ [ diff ] keep , (group-cycles)
+ ] unless-empty ;
+
+: group-cycles ( seq -- seqs )
+ [ (group-cycles) ] { } make ;
+
+: remove-dead-mappings ( seq -- seq' )
+ prune [ [ from-reg ] [ to-reg ] bi = not ] filter ;
+
+: parallel-mappings ( operations -- seq )
+ [
+ [ independent-assignment? not ] partition %
+ [ start? not ] partition
+ [ trace-chain ] map concat dup %
+ diff group-cycles [ break-cycle ] map concat %
+ ] { } make remove-dead-mappings ;
+
+: mapping-instructions ( mappings -- insns )
+ [ { } ] [
+ [
+ [ set-tos/froms ] [ parallel-mappings ] bi
+ [ [ >insn ] each ] { } make
+ ] with-scope
+ ] if-empty ;
+
+: init-mapping ( -- )
+ H{ } clone spill-temps set ;
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors math sequences ;
+USING: kernel accessors math sequences grouping namespaces
+compiler.cfg.rpo ;
IN: compiler.cfg.linear-scan.numbering
: number-instructions ( rpo -- )
instructions>> [
[ (>>insn#) ] [ drop 2 + ] 2bi
] each
- ] each drop ;
\ No newline at end of file
+ ] each-basic-block drop ;
+
+SYMBOL: check-numbering?
+
+ERROR: bad-numbering bb ;
+
+: check-block-numbering ( bb -- )
+ dup instructions>> [ insn#>> ] map sift [ <= ] monotonic?
+ [ drop ] [ bad-numbering ] if ;
+
+: check-numbering ( cfg -- )
+ check-numbering? get [ [ check-block-numbering ] each-basic-block ] [ drop ] if ;
\ No newline at end of file
+++ /dev/null
-USING: accessors arrays compiler.cfg compiler.cfg.instructions
-compiler.cfg.linear-scan.debugger
-compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.numbering
-compiler.cfg.linear-scan.resolve compiler.cfg.predecessors
-compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel
-namespaces tools.test vectors ;
-IN: compiler.cfg.linear-scan.resolve.tests
-
-[ { 1 2 3 4 5 6 } ] [
- { 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array
-] unit-test
-
-V{
- T{ ##peek f V int-regs 0 D 0 }
- T{ ##branch }
-} 0 test-bb
-
-V{
- T{ ##replace f V int-regs 0 D 1 }
- T{ ##return }
-} 1 test-bb
-
-1 get 1vector 0 get (>>successors)
-
-cfg new 0 get >>entry
-compute-predecessors
-dup reverse-post-order number-instructions
-drop
-
-CONSTANT: test-live-interval-1
-T{ live-interval
- { start 0 }
- { end 6 }
- { uses V{ 0 6 } }
- { ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } }
- { spill-to 0 }
- { vreg V int-regs 0 }
-}
-
-[ f ] [
- 0 get test-live-interval-1 spill-to
-] unit-test
-
-[ 0 ] [
- 1 get test-live-interval-1 spill-to
-] unit-test
-
-CONSTANT: test-live-interval-2
-T{ live-interval
- { start 0 }
- { end 6 }
- { uses V{ 0 6 } }
- { ranges V{ T{ live-range f 0 2 } T{ live-range f 4 6 } } }
- { reload-from 0 }
- { vreg V int-regs 0 }
-}
-
-[ 0 ] [
- 0 get test-live-interval-2 reload-from
-] unit-test
-
-[ f ] [
- 1 get test-live-interval-2 reload-from
-] unit-test
\ No newline at end of file
-! Copyright (C) 2009 Slava Pestov
+! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel math namespaces sequences
-classes.tuple classes.parser parser fry words make arrays
-locals combinators compiler.cfg.linear-scan.live-intervals
-compiler.cfg.liveness compiler.cfg.instructions ;
+USING: accessors arrays assocs combinators
+combinators.short-circuit fry kernel locals
+make math sequences
+compiler.cfg.rpo
+compiler.cfg.liveness
+compiler.cfg.utilities
+compiler.cfg.instructions
+compiler.cfg.linear-scan.assignment
+compiler.cfg.linear-scan.mapping ;
IN: compiler.cfg.linear-scan.resolve
-<<
-
-TUPLE: operation from to reg-class ;
-
-SYNTAX: OPERATION:
- CREATE-CLASS dup save-location
- [ operation { } define-tuple-class ]
- [
- [ scan-word scan-word ] keep
- '[
- [ [ _ execute ] [ _ execute ] bi* ]
- [ vreg>> reg-class>> ]
- bi _ boa ,
- ] (( from to -- )) define-declared
- ] bi ;
-
->>
-
-: reload-from ( bb live-interval -- n/f )
- 2dup [ block-from ] [ start>> ] bi* =
- [ nip reload-from>> ] [ 2drop f ] if ;
-
-: spill-to ( bb live-interval -- n/f )
- 2dup [ block-to ] [ end>> ] bi* =
- [ nip spill-to>> ] [ 2drop f ] if ;
-
-OPERATION: memory->memory spill-to>> reload-from>>
-OPERATION: register->memory reg>> reload-from>>
-OPERATION: memory->register spill-to>> reg>>
-OPERATION: register->register reg>> reg>>
-
-:: add-mapping ( bb1 bb2 li1 li2 -- )
- bb2 li2 reload-from [
- bb1 li1 spill-to
- [ li1 li2 memory->memory ]
- [ li1 li2 register->memory ] if
+: add-mapping ( from to reg-class -- )
+ over spill-slot? [
+ pick spill-slot?
+ [ memory->memory ]
+ [ register->memory ] if
] [
- bb1 li1 spill-to
- [ li1 li2 memory->register ]
- [ li1 li2 register->register ] if
+ pick spill-slot?
+ [ memory->register ]
+ [ register->register ] if
] if ;
-: resolve-value-data-flow ( bb to vreg -- )
- [ 2dup ] dip
- live-intervals get at
- [ [ block-to ] dip child-interval-at ]
- [ [ block-from ] dip child-interval-at ]
- bi-curry bi* 2dup eq? [ 2drop 2drop ] [ add-mapping ] if ;
+:: resolve-value-data-flow ( bb to vreg -- )
+ vreg bb vreg-at-end
+ vreg to vreg-at-start
+ 2dup eq? [ 2drop ] [ vreg reg-class>> add-mapping ] if ;
: compute-mappings ( bb to -- mappings )
[
[ resolve-value-data-flow ] with with each
] { } make ;
-GENERIC: >insn ( operation -- )
-
-M: memory->memory >insn
- [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
-
-M: register->memory >insn
- [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
-
-M: memory->register >insn
- [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
-
-M: register->register >insn
- [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
-
-: mapping-instructions ( mappings -- insns )
- [ [ >insn ] each ] { } make ;
-
-: fork? ( from to -- ? )
- [ successors>> length 1 >= ]
- [ predecessors>> length 1 = ] bi* and ; inline
-
-: insert-position/fork ( from to -- before after )
- nip instructions>> [ >array ] [ dup delete-all ] bi swap ;
-
-: join? ( from to -- ? )
- [ successors>> length 1 = ]
- [ predecessors>> length 1 >= ] bi* and ; inline
-
-: insert-position/join ( from to -- before after )
- drop instructions>> dup pop 1array ;
-
-: insert-position ( bb to -- before after )
- {
- { [ 2dup fork? ] [ insert-position/fork ] }
- { [ 2dup join? ] [ insert-position/join ] }
- } cond ;
-
-: 3append-here ( seq2 seq1 seq3 -- )
- #! Mutate seq1
- swap '[ _ push-all ] bi@ ;
-
-: perform-mappings ( mappings bb to -- )
- pick empty? [ 3drop ] [
- [ mapping-instructions ] 2dip
- insert-position 3append-here
+: perform-mappings ( bb to mappings -- )
+ dup empty? [ 3drop ] [
+ mapping-instructions <simple-block>
+ insert-basic-block
] if ;
: resolve-edge-data-flow ( bb to -- )
- [ compute-mappings ] [ perform-mappings ] 2bi ;
+ 2dup compute-mappings perform-mappings ;
: resolve-block-data-flow ( bb -- )
dup successors>> [ resolve-edge-data-flow ] with each ;
-: resolve-data-flow ( rpo -- )
- [ resolve-block-data-flow ] each ;
\ No newline at end of file
+: resolve-data-flow ( cfg -- )
+ [ resolve-block-data-flow ] each-basic-block ;
combinators assocs arrays locals cpu.architecture
compiler.cfg
compiler.cfg.rpo
-compiler.cfg.liveness
+compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.cfg.instructions ;
IN: compiler.cfg.linearization
#! don't need to branch.
[ number>> ] bi@ 1 - = ; inline
-: branch-to-branch? ( successor -- ? )
- #! A branch to a block containing just a jump return is cloned.
- instructions>> dup length 2 = [
- [ first ##epilogue? ]
- [ second [ ##return? ] [ ##jump? ] bi or ] bi and
- ] [ drop f ] if ;
-
: emit-branch ( basic-block successor -- )
- {
- { [ 2dup useless-branch? ] [ 2drop ] }
- { [ dup branch-to-branch? ] [ nip linearize-basic-block ] }
- [ nip number>> _branch ]
- } cond ;
+ 2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
M: ##branch linearize-insn
drop dup successors>> first emit-branch ;
+: successors ( bb -- first second ) successors>> first2 ; inline
+
: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc )
- [ dup successors>> first2 ]
+ [ dup successors ]
[ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
M: ##compare-float-branch linearize-insn
[ binary-conditional _compare-float-branch ] with-regs emit-branch ;
+: overflow-conditional ( basic-block insn -- basic-block successor label2 dst src1 src2 )
+ [ dup successors number>> ]
+ [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
+
+M: ##fixnum-add linearize-insn
+ [ overflow-conditional _fixnum-add ] with-regs emit-branch ;
+
+M: ##fixnum-sub linearize-insn
+ [ overflow-conditional _fixnum-sub ] with-regs emit-branch ;
+
+M: ##fixnum-mul linearize-insn
+ [ overflow-conditional _fixnum-mul ] with-regs emit-branch ;
+
M: ##dispatch linearize-insn
swap
[ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
[ successors>> [ number>> _dispatch-label ] each ]
bi* ;
-: gc-root-registers ( n live-registers -- n )
- [
- [ second 2array , ]
- [ first reg-class>> reg-size + ]
- 2bi
- ] each ;
-
-: gc-root-spill-slots ( n live-spill-slots -- n )
+: (compute-gc-roots) ( n live-values -- n )
[
- dup first reg-class>> int-regs eq? [
- [ second <spill-slot> 2array , ]
- [ first reg-class>> reg-size + ]
- 2bi
- ] [ drop ] if
- ] each ;
+ [ nip 2array , ]
+ [ drop reg-class>> reg-size + ]
+ 3bi
+ ] assoc-each ;
-: oop-registers ( regs -- regs' )
- [ first reg-class>> int-regs eq? ] filter ;
+: oop-values ( regs -- regs' )
+ [ drop reg-class>> int-regs eq? ] assoc-filter ;
-: data-registers ( regs -- regs' )
- [ first reg-class>> double-float-regs eq? ] filter ;
+: data-values ( regs -- regs' )
+ [ drop reg-class>> double-float-regs eq? ] assoc-filter ;
-:: compute-gc-roots ( live-registers live-spill-slots -- alist )
+: compute-gc-roots ( live-values -- alist )
[
- 0
+ [ 0 ] dip
! we put float registers last; the GC doesn't actually scan them
- live-registers oop-registers gc-root-registers
- live-spill-slots gc-root-spill-slots
- live-registers data-registers gc-root-registers
+ [ oop-values (compute-gc-roots) ]
+ [ data-values (compute-gc-roots) ] bi
drop
] { } make ;
-: count-gc-roots ( live-registers live-spill-slots -- n )
+: count-gc-roots ( live-values -- n )
! Size of GC root area, minus the float registers
- [ oop-registers length ] bi@ + ;
+ oop-values assoc-size ;
M: ##gc linearize-insn
nip
[ temp1>> ]
[ temp2>> ]
[
- [ live-registers>> ] [ live-spill-slots>> ] bi
+ live-values>>
[ compute-gc-roots ]
[ count-gc-roots ]
[ gc-roots-size ]
- 2tri
+ tri
] tri
_gc
] with-regs ;
+++ /dev/null
-Slava Pestov
\ No newline at end of file
--- /dev/null
+USING: compiler.cfg.liveness compiler.cfg.debugger
+compiler.cfg.instructions compiler.cfg.predecessors
+compiler.cfg.registers compiler.cfg cpu.architecture
+accessors namespaces sequences kernel tools.test ;
+IN: compiler.cfg.liveness.tests
+
+! Sanity check...
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f V int-regs 1 D 1 }
+ T{ ##peek f V int-regs 1 D 1 }
+} 1 test-bb
+
+V{
+ T{ ##replace f V int-regs 2 D 0 }
+} 2 test-bb
+
+V{
+ T{ ##replace f V int-regs 3 D 0 }
+} 3 test-bb
+
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+
+cfg new 1 get >>entry
+compute-predecessors
+compute-live-sets
+
+[
+ H{
+ { V int-regs 1 V int-regs 1 }
+ { V int-regs 2 V int-regs 2 }
+ { V int-regs 3 V int-regs 3 }
+ }
+]
+[ 1 get live-in ]
+unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces deques accessors sets sequences assocs fry
-dlists compiler.cfg.def-use compiler.cfg.instructions
-compiler.cfg.rpo ;
+USING: kernel accessors assocs sequences sets
+compiler.cfg.def-use compiler.cfg.dataflow-analysis
+compiler.cfg.instructions ;
IN: compiler.cfg.liveness
-! This is a backward dataflow analysis. See http://en.wikipedia.org/wiki/Liveness_analysis
+! See http://en.wikipedia.org/wiki/Liveness_analysis
+! Do not run after SSA construction
-! Assoc mapping basic blocks to sets of vregs
-SYMBOL: live-ins
+BACKWARD-ANALYSIS: live
-: live-in ( basic-block -- set ) live-ins get at ;
+: transfer-liveness ( live-set instructions -- live-set' )
+ [ clone ] [ <reversed> ] bi* [
+ [ uses-vregs [ over conjoin ] each ]
+ [ defs-vregs [ over delete-at ] each ] bi
+ ] each ;
-! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
-! is in conrrespondence with a predecessor
-SYMBOL: phi-live-ins
+: local-live-in ( instructions -- live-set )
+ [ ##phi? not ] filter [ H{ } ] dip transfer-liveness keys ;
-: phi-live-in ( predecessor basic-block -- set )
- [ predecessors>> index ] keep phi-live-ins get at
- dup [ nth ] [ 2drop f ] if ;
+M: live-analysis transfer-set
+ drop instructions>> transfer-liveness ;
-! Assoc mapping basic blocks to sets of vregs
-SYMBOL: live-outs
-
-: live-out ( basic-block -- set ) live-outs get at ;
-
-SYMBOL: work-list
-
-: add-to-work-list ( basic-blocks -- )
- work-list get '[ _ push-front ] each ;
-
-: map-unique ( seq quot -- assoc )
- map concat unique ; inline
-
-: gen-set ( instructions -- seq )
- [ ##phi? not ] filter [ uses-vregs ] map-unique ;
-
-: kill-set ( instructions -- seq )
- [ [ defs-vregs ] [ temp-vregs ] bi append ] map-unique ;
-
-: compute-live-in ( basic-block -- live-in )
- dup instructions>>
- [ [ live-out ] [ gen-set ] bi* assoc-union ]
- [ nip kill-set ]
- 2bi assoc-diff ;
-
-: compute-phi-live-in ( basic-block -- phi-live-in )
- instructions>> [ ##phi? ] filter
- [ f ] [ [ inputs>> ] map flip [ unique ] map ] if-empty ;
-
-: update-live-in ( basic-block -- changed? )
- [ [ compute-live-in ] keep live-ins get maybe-set-at ]
- [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ]
- bi and ;
-
-: compute-live-out ( basic-block -- live-out )
- [ successors>> [ live-in ] map ]
- [ dup successors>> [ phi-live-in ] with map ] bi
- append assoc-combine ;
-
-: update-live-out ( basic-block -- changed? )
- [ compute-live-out ] keep
- live-outs get maybe-set-at ;
-
-: liveness-step ( basic-block -- )
- dup update-live-out [
- dup update-live-in
- [ predecessors>> add-to-work-list ] [ drop ] if
- ] [ drop ] if ;
-
-: compute-liveness ( cfg -- cfg' )
- <hashed-dlist> work-list set
- H{ } clone live-ins set
- H{ } clone phi-live-ins set
- H{ } clone live-outs set
- dup post-order add-to-work-list
- work-list get [ liveness-step ] slurp-deque ;
+M: live-analysis join-sets
+ drop assoc-combine ;
\ 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: fry accessors kernel assocs compiler.cfg.liveness compiler.cfg.rpo ;
-IN: compiler.cfg.local
-
-: optimize-basic-block ( bb init-quot insn-quot -- )
- [ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline
-
-: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' )
- [ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ; inline
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.cfg.linearization compiler.cfg.two-operand
-compiler.cfg.liveness compiler.cfg.gc-checks compiler.cfg.linear-scan
+compiler.cfg.gc-checks compiler.cfg.linear-scan
compiler.cfg.build-stack-frame compiler.cfg.rpo ;
IN: compiler.cfg.mr
: build-mr ( cfg -- mr )
convert-two-operand
- compute-liveness
insert-gc-checks
linear-scan
flatten-cfg
-USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
-compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors
-sequences.private math sbufs math.private slots.private strings ;
+USING: accessors arrays compiler.cfg.checker
+compiler.cfg.debugger compiler.cfg.def-use
+compiler.cfg.instructions fry kernel kernel.private math
+math.partial-dispatch math.private sbufs sequences sequences.private sets
+slots.private strings strings.private tools.test vectors layouts ;
IN: compiler.cfg.optimizer.tests
! Miscellaneous tests
[ [ 2 fixnum+ ] when 3 ]
[ [ 2 fixnum- ] when 3 ]
[ 10000 [ ] times ]
+ [
+ over integer? [
+ over dup 16 <-integer-fixnum
+ [ 0 >=-integer-fixnum ] [ drop f ] if [
+ nip dup
+ [ ] [ ] if
+ ] [ 2drop f ] if
+ ] [ 2drop f ] if
+ ]
+ [
+ pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
+ set-string-nth-fast
+ ]
} [
[ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
] each
+
+cell 8 = [
+ [ t ]
+ [
+ [
+ 1 50 fixnum-shift-fast fixnum+fast
+ ] test-mr first instructions>> [ ##add? ] any?
+ ] unit-test
+] when
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors combinators namespaces
+compiler.cfg.tco
compiler.cfg.predecessors
-compiler.cfg.useless-blocks
-compiler.cfg.height
+compiler.cfg.useless-conditionals
compiler.cfg.stack-analysis
+compiler.cfg.branch-splitting
+compiler.cfg.block-joining
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
compiler.cfg.dce
compiler.cfg.write-barrier
-compiler.cfg.liveness
compiler.cfg.rpo
compiler.cfg.phi-elimination
compiler.cfg.checker ;
] when ;
: optimize-cfg ( cfg -- cfg' )
+ ! Note that compute-predecessors has to be called several times.
+ ! The passes that need this document it.
[
- compute-predecessors
- delete-useless-blocks
+ optimize-tail-calls
delete-useless-conditionals
- normalize-height
+ compute-predecessors
+ split-branches
+ join-blocks
+ compute-predecessors
stack-analysis
- compute-liveness
alias-analysis
value-numbering
+ compute-predecessors
eliminate-dead-code
eliminate-write-barriers
eliminate-phis
-Slava Pestov
\ No newline at end of file
+Slava Pestov
+Daniel Ehrenberg
--- /dev/null
+! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.cfg.instructions compiler.cfg compiler.cfg.registers
+compiler.cfg.comparisons compiler.cfg.debugger locals
+compiler.cfg.phi-elimination kernel accessors sequences classes
+namespaces tools.test cpu.architecture arrays ;
+IN: compiler.cfg.phi-elimination.tests
+
+V{ T{ ##branch } } 0 test-bb
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
+} 1 test-bb
+
+V{
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##phi f V int-regs 3 { } }
+ T{ ##replace f V int-regs 3 D 0 }
+ T{ ##return }
+} 4 test-bb
+
+4 get instructions>> first
+2 get V int-regs 1 2array
+3 get V int-regs 2 2array 2array
+>>inputs drop
+
+test-diamond
+
+3 vreg-counter set-global
+
+[ ] [ cfg new 0 get >>entry eliminate-phis drop ] unit-test
+
+[ T{ ##copy f V int-regs 4 V int-regs 1 } ] [
+ 2 get successors>> first instructions>> first
+] unit-test
+
+[ T{ ##copy f V int-regs 4 V int-regs 2 } ] [
+ 3 get successors>> first instructions>> first
+] unit-test
+
+[ T{ ##copy f V int-regs 3 V int-regs 4 } ] [
+ 4 get instructions>> first
+] unit-test
+
+[ 3 ] [ 4 get instructions>> length ] unit-test
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors compiler.cfg compiler.cfg.instructions
-compiler.cfg.rpo fry kernel sequences ;
+USING: accessors assocs fry kernel sequences namespaces
+compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.utilities compiler.cfg.hats make
+locals ;
IN: compiler.cfg.phi-elimination
: insert-copy ( predecessor input output -- )
'[ _ _ swap ##copy ] add-instructions ;
-: eliminate-phi ( bb ##phi -- )
- [ predecessors>> ] [ [ inputs>> ] [ dst>> ] bi ] bi*
- '[ _ insert-copy ] 2each ;
+: eliminate-phi ( ##phi -- ##copy )
+ i
+ [ [ inputs>> ] dip '[ _ insert-copy ] assoc-each ]
+ [ [ dst>> ] dip \ ##copy new-insn ]
+ 2bi ;
: eliminate-phi-step ( bb -- )
- dup [
- [ ##phi? ] partition
- [ [ eliminate-phi ] with each ] dip
- ] change-instructions drop ;
+ H{ } clone added-instructions set
+ [ instructions>> [ dup ##phi? [ eliminate-phi ] when ] change-each ]
+ [ insert-basic-blocks ]
+ bi ;
: eliminate-phis ( cfg -- cfg' )
- dup [ eliminate-phi-step ] each-basic-block ;
\ No newline at end of file
+ dup [ eliminate-phi-step ] each-basic-block
+ cfg-changed ;
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences compiler.cfg.rpo ;
+USING: kernel accessors combinators fry sequences assocs compiler.cfg.rpo
+compiler.cfg.instructions ;
IN: compiler.cfg.predecessors
-: predecessors-step ( bb -- )
+: update-predecessors ( bb -- )
dup successors>> [ predecessors>> push ] with each ;
+: update-phi ( bb ##phi -- )
+ [
+ swap predecessors>>
+ '[ drop _ memq? ] assoc-filter
+ ] change-inputs drop ;
+
+: update-phis ( bb -- )
+ dup instructions>> [
+ dup ##phi? [ update-phi ] [ 2drop ] if
+ ] with each ;
+
: compute-predecessors ( cfg -- cfg' )
- [ [ V{ } clone >>predecessors drop ] each-basic-block ]
- [ [ predecessors-step ] each-basic-block ]
- [ ]
- tri ;
+ {
+ [ [ V{ } clone >>predecessors drop ] each-basic-block ]
+ [ [ update-predecessors ] each-basic-block ]
+ [ [ update-phis ] each-basic-block ]
+ [ ]
+ } cleave ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors namespaces kernel arrays parser ;
+USING: accessors namespaces kernel arrays parser math math.order ;
IN: compiler.cfg.registers
! Virtual registers, used by CFG and machine IRs
-TUPLE: vreg { reg-class read-only } { n read-only } ;
+TUPLE: vreg { reg-class read-only } { n fixnum read-only } ;
+
+M: vreg equal? over vreg? [ [ n>> ] bi@ eq? ] [ 2drop f ] if ;
+
+M: vreg hashcode* nip n>> ;
+
SYMBOL: vreg-counter
+
: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
-! Stack locations
+! Stack locations -- 'n' is an index starting from the top of the stack
+! going down. So 0 is the top of the stack, 1 is what would be the top
+! of the stack after a 'drop', and so on.
+
+! ##inc-d and ##inc-r affect locations as follows. Location D 0 before
+! an ##inc-d 1 becomes D 1 after ##inc-d 1.
TUPLE: loc { n read-only } ;
TUPLE: ds-loc < loc ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel namespaces sequences
+compiler.cfg.instructions compiler.cfg.registers ;
+IN: compiler.cfg.renaming
+
+SYMBOL: renamings
+
+: rename-value ( vreg -- vreg' ) renamings get ?at drop ;
+
+GENERIC: rename-insn-defs ( insn -- )
+
+M: ##flushable rename-insn-defs
+ [ rename-value ] change-dst
+ drop ;
+
+M: ##fixnum-overflow rename-insn-defs
+ [ rename-value ] change-dst
+ drop ;
+
+M: _fixnum-overflow rename-insn-defs
+ [ rename-value ] change-dst
+ drop ;
+
+M: insn rename-insn-defs drop ;
+
+GENERIC: rename-insn-uses ( insn -- )
+
+M: ##effect rename-insn-uses
+ [ rename-value ] change-src
+ drop ;
+
+M: ##unary rename-insn-uses
+ [ rename-value ] change-src
+ drop ;
+
+M: ##binary rename-insn-uses
+ [ rename-value ] change-src1
+ [ rename-value ] change-src2
+ drop ;
+
+M: ##binary-imm rename-insn-uses
+ [ rename-value ] change-src1
+ drop ;
+
+M: ##slot rename-insn-uses
+ [ rename-value ] change-obj
+ [ rename-value ] change-slot
+ drop ;
+
+M: ##slot-imm rename-insn-uses
+ [ rename-value ] change-obj
+ drop ;
+
+M: ##set-slot rename-insn-uses
+ dup call-next-method
+ [ rename-value ] change-obj
+ [ rename-value ] change-slot
+ drop ;
+
+M: ##string-nth rename-insn-uses
+ [ rename-value ] change-obj
+ [ rename-value ] change-index
+ drop ;
+
+M: ##set-string-nth-fast rename-insn-uses
+ dup call-next-method
+ [ rename-value ] change-obj
+ [ rename-value ] change-index
+ drop ;
+
+M: ##set-slot-imm rename-insn-uses
+ dup call-next-method
+ [ rename-value ] change-obj
+ drop ;
+
+M: ##alien-getter rename-insn-uses
+ dup call-next-method
+ [ rename-value ] change-src
+ drop ;
+
+M: ##alien-setter rename-insn-uses
+ dup call-next-method
+ [ rename-value ] change-value
+ drop ;
+
+M: ##conditional-branch rename-insn-uses
+ [ rename-value ] change-src1
+ [ rename-value ] change-src2
+ drop ;
+
+M: ##compare-imm-branch rename-insn-uses
+ [ rename-value ] change-src1
+ drop ;
+
+M: ##dispatch rename-insn-uses
+ [ rename-value ] change-src
+ drop ;
+
+M: ##fixnum-overflow rename-insn-uses
+ [ rename-value ] change-src1
+ [ rename-value ] change-src2
+ drop ;
+
+M: insn rename-insn-uses drop ;
+
+: fresh-vreg ( vreg -- vreg' )
+ reg-class>> next-vreg ;
+
+GENERIC: fresh-insn-temps ( insn -- )
+
+M: ##write-barrier fresh-insn-temps
+ [ fresh-vreg ] change-card#
+ [ fresh-vreg ] change-table
+ drop ;
+
+M: ##unary/temp fresh-insn-temps
+ [ fresh-vreg ] change-temp drop ;
+
+M: ##allot fresh-insn-temps
+ [ fresh-vreg ] change-temp drop ;
+
+M: ##dispatch fresh-insn-temps
+ [ fresh-vreg ] change-temp drop ;
+
+M: ##slot fresh-insn-temps
+ [ fresh-vreg ] change-temp drop ;
+
+M: ##set-slot fresh-insn-temps
+ [ fresh-vreg ] change-temp drop ;
+
+M: ##string-nth fresh-insn-temps
+ [ fresh-vreg ] change-temp drop ;
+
+M: ##set-string-nth-fast fresh-insn-temps
+ [ fresh-vreg ] change-temp drop ;
+
+M: ##compare fresh-insn-temps
+ [ fresh-vreg ] change-temp drop ;
+
+M: ##compare-imm fresh-insn-temps
+ [ fresh-vreg ] change-temp drop ;
+
+M: ##compare-float fresh-insn-temps
+ [ fresh-vreg ] change-temp drop ;
+
+M: ##gc fresh-insn-temps
+ [ fresh-vreg ] change-temp1
+ [ fresh-vreg ] change-temp2
+ drop ;
+
+M: _dispatch fresh-insn-temps
+ [ fresh-vreg ] change-temp drop ;
+
+M: insn fresh-insn-temps drop ;
\ No newline at end of file
: each-basic-block ( cfg quot -- )
[ reverse-post-order ] dip each ; inline
+
+: optimize-basic-block ( bb quot -- )
+ [ drop basic-block set ]
+ [ change-instructions drop ] 2bi ; inline
+
+: local-optimization ( cfg quot: ( insns -- insns' ) -- cfg' )
+ dupd '[ _ optimize-basic-block ] each-basic-block ; inline
\ No newline at end of file
--- /dev/null
+USING: accessors compiler.cfg compiler.cfg.debugger
+compiler.cfg.dominance compiler.cfg.instructions
+compiler.cfg.predecessors compiler.cfg.ssa assocs
+compiler.cfg.registers cpu.architecture kernel namespaces sequences
+tools.test vectors ;
+IN: compiler.cfg.ssa.tests
+
+: reset-counters ( -- )
+ ! Reset counters so that results are deterministic w.r.t. hash order
+ 0 vreg-counter set-global
+ 0 basic-block set-global ;
+
+reset-counters
+
+V{
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##add-imm f V int-regs 2 V int-regs 1 50 }
+ T{ ##add-imm f V int-regs 2 V int-regs 2 10 }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##load-immediate f V int-regs 3 3 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##load-immediate f V int-regs 3 4 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##replace f V int-regs 3 D 0 }
+ T{ ##return }
+} 3 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+1 get 3 get 1vector >>successors drop
+2 get 3 get 1vector >>successors drop
+
+: test-ssa ( -- )
+ cfg new 0 get >>entry
+ compute-predecessors
+ construct-ssa
+ drop ;
+
+[ ] [ test-ssa ] unit-test
+
+[
+ V{
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##add-imm f V int-regs 2 V int-regs 1 50 }
+ T{ ##add-imm f V int-regs 3 V int-regs 2 10 }
+ T{ ##branch }
+ }
+] [ 0 get instructions>> ] unit-test
+
+[
+ V{
+ T{ ##load-immediate f V int-regs 4 3 }
+ T{ ##branch }
+ }
+] [ 1 get instructions>> ] unit-test
+
+[
+ V{
+ T{ ##load-immediate f V int-regs 5 4 }
+ T{ ##branch }
+ }
+] [ 2 get instructions>> ] unit-test
+
+: clean-up-phis ( insns -- insns' )
+ [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ;
+
+[
+ V{
+ T{ ##phi f V int-regs 6 H{ { 1 V int-regs 4 } { 2 V int-regs 5 } } }
+ T{ ##replace f V int-regs 6 D 0 }
+ T{ ##return }
+ }
+] [
+ 3 get instructions>>
+ clean-up-phis
+] unit-test
+
+reset-counters
+
+V{ } 0 test-bb
+V{ } 1 test-bb
+V{ T{ ##peek f V int-regs 0 D 0 } } 2 test-bb
+V{ T{ ##peek f V int-regs 0 D 0 } } 3 test-bb
+V{ T{ ##replace f V int-regs 0 D 0 } } 4 test-bb
+V{ } 5 test-bb
+V{ } 6 test-bb
+
+0 get 1 get 5 get V{ } 2sequence >>successors drop
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+2 get 4 get 1vector >>successors drop
+3 get 4 get 1vector >>successors drop
+4 get 6 get 1vector >>successors drop
+5 get 6 get 1vector >>successors drop
+
+[ ] [ test-ssa ] unit-test
+
+[
+ V{
+ T{ ##phi f V int-regs 3 H{ { 2 V int-regs 1 } { 3 V int-regs 2 } } }
+ T{ ##replace f V int-regs 3 D 0 }
+ }
+] [
+ 4 get instructions>>
+ clean-up-phis
+] 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: namespaces kernel accessors sequences fry assocs
+sets math combinators
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.def-use
+compiler.cfg.renaming
+compiler.cfg.liveness
+compiler.cfg.registers
+compiler.cfg.dominance
+compiler.cfg.instructions ;
+IN: compiler.cfg.ssa
+
+! SSA construction. Predecessors must be computed first.
+
+! This is the classical algorithm based on dominance frontiers, except
+! we consult liveness information to build pruned SSA:
+! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.25.8240
+
+! Eventually might be worth trying something fancier:
+! http://portal.acm.org/citation.cfm?id=1065887.1065890
+
+<PRIVATE
+
+! Maps vreg to sequence of basic blocks
+SYMBOL: defs
+
+! Maps basic blocks to sequences of vregs
+SYMBOL: inserting-phi-nodes
+
+: compute-defs ( cfg -- )
+ H{ } clone dup defs set
+ '[
+ dup instructions>> [
+ defs-vregs [
+ _ conjoin-at
+ ] with each
+ ] with each
+ ] each-basic-block ;
+
+: insert-phi-node-later ( vreg bb -- )
+ 2dup live-in key? [
+ [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep
+ inserting-phi-nodes get push-at
+ ] [ 2drop ] if ;
+
+: compute-phi-nodes-for ( vreg bbs -- )
+ keys dup length 2 >= [
+ iterated-dom-frontier [
+ insert-phi-node-later
+ ] with each
+ ] [ 2drop ] if ;
+
+: compute-phi-nodes ( -- )
+ H{ } clone inserting-phi-nodes set
+ defs get [ compute-phi-nodes-for ] assoc-each ;
+
+: insert-phi-nodes-in ( phis bb -- )
+ [ append ] change-instructions drop ;
+
+: insert-phi-nodes ( -- )
+ inserting-phi-nodes get [ swap insert-phi-nodes-in ] assoc-each ;
+
+SYMBOLS: stacks originals ;
+
+: init-renaming ( -- )
+ H{ } clone stacks set
+ H{ } clone originals set ;
+
+: gen-name ( vreg -- vreg' )
+ [ reg-class>> next-vreg ] keep
+ [ stacks get push-at ]
+ [ swap originals get set-at ]
+ [ drop ]
+ 2tri ;
+
+: top-name ( vreg -- vreg' )
+ stacks get at last ;
+
+GENERIC: rename-insn ( insn -- )
+
+M: insn rename-insn
+ [ dup uses-vregs [ dup top-name ] { } map>assoc renamings set rename-insn-uses ]
+ [ dup defs-vregs [ dup gen-name ] { } map>assoc renamings set rename-insn-defs ]
+ bi ;
+
+M: ##phi rename-insn
+ dup defs-vregs [ dup gen-name ] { } map>assoc renamings set rename-insn-defs ;
+
+: rename-insns ( bb -- )
+ instructions>> [ rename-insn ] each ;
+
+: rename-successor-phi ( phi bb -- )
+ swap inputs>> [ top-name ] change-at ;
+
+: rename-successor-phis ( succ bb -- )
+ [ inserting-phi-nodes get at ] dip
+ '[ _ rename-successor-phi ] each ;
+
+: rename-successors-phis ( bb -- )
+ [ successors>> ] keep '[ _ rename-successor-phis ] each ;
+
+: pop-stacks ( bb -- )
+ instructions>> [
+ defs-vregs originals get stacks get
+ '[ _ at _ at pop* ] each
+ ] each ;
+
+: rename-in-block ( bb -- )
+ {
+ [ rename-insns ]
+ [ rename-successors-phis ]
+ [ dom-children [ rename-in-block ] each ]
+ [ pop-stacks ]
+ } cleave ;
+
+: rename ( cfg -- )
+ init-renaming
+ entry>> rename-in-block ;
+
+PRIVATE>
+
+: construct-ssa ( cfg -- cfg' )
+ {
+ [ ]
+ [ compute-live-sets ]
+ [ compute-dominance ]
+ [ compute-defs compute-phi-nodes insert-phi-nodes ]
+ [ rename ]
+ } cleave ;
\ No newline at end of file
--- /dev/null
+IN: compiler.cfg.stack-analysis.merge.tests
+USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
+ compiler.cfg.instructions compiler.cfg.stack-analysis.state
+compiler.cfg.utilities compiler.cfg compiler.cfg.registers
+compiler.cfg.debugger cpu.architecture make assocs namespaces
+sequences kernel classes ;
+
+[
+ { D 0 }
+ { V int-regs 0 V int-regs 1 }
+] [
+ <state>
+
+ <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
+ <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
+
+ <state> H{ { D 0 V int-regs 0 } } >>locs>vregs
+ <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+
+ H{ } clone added-instructions set
+ V{ } clone added-phis set
+ merge-locs locs>vregs>> keys added-phis get values first
+] unit-test
+
+[
+ { D 0 }
+ ##peek
+] [
+ <state>
+
+ <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
+ <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
+
+ <state>
+ <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+
+ H{ } clone added-instructions set
+ V{ } clone added-phis set
+ [ merge-locs locs>vregs>> keys ] { } make drop
+ 1 get added-instructions get at first class
+] unit-test
+
+[
+ 0 ##inc-d
+] [
+ <state>
+
+ <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
+ <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
+
+ H{ } clone added-instructions set
+ V{ } clone added-phis set
+
+ <state> -1 >>ds-height
+ <state> 2array
+
+ [ merge-ds-heights ds-height>> ] { } make drop
+ 1 get added-instructions get at first class
+] unit-test
+
+[
+ 0
+ { D 0 }
+ { 1 1 }
+] [
+ <state>
+
+ <basic-block> V{ T{ ##branch } } >>instructions
+ <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+ H{ } clone added-instructions set
+ V{ } clone added-phis set
+
+ [
+ <state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
+ <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+
+ [ merge-locs [ ds-height>> ] [ locs>vregs>> keys ] bi ] { } make drop
+ ] keep
+ [ instructions>> length ] map
+] unit-test
+
+[
+ -1
+ { D -1 }
+ { 1 1 }
+] [
+ <state>
+
+ <basic-block> V{ T{ ##branch } } >>instructions
+ <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+ H{ } clone added-instructions set
+ V{ } clone added-phis set
+
+ [
+ <state> -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs
+ <state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array
+
+ [ [ merge-ds-heights ] [ merge-locs ] 2bi ] { } make drop
+ [ ds-height>> ] [ locs>vregs>> keys ] bi
+ ] keep
+ [ instructions>> length ] map
+] unit-test
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs sequences accessors fry combinators grouping
-sets compiler.cfg compiler.cfg.hats
-compiler.cfg.stack-analysis.state ;
+USING: kernel assocs sequences accessors fry combinators grouping sets
+arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats
+compiler.cfg.instructions compiler.cfg.stack-analysis.state
+compiler.cfg.registers compiler.cfg.utilities cpu.architecture ;
IN: compiler.cfg.stack-analysis.merge
: initial-state ( bb states -- state ) 2drop <state> ;
: single-predecessor ( bb states -- state ) nip first clone ;
-ERROR: must-equal-failed seq ;
+: save-ds-height ( n -- )
+ dup 0 = [ drop ] [ ##inc-d ] if ;
-: must-equal ( seq -- elt )
- dup all-equal? [ first ] [ must-equal-failed ] if ;
+: merge-ds-heights ( state predecessors states -- state )
+ [ ds-height>> ] map dup all-equal?
+ [ nip first >>ds-height ]
+ [ [ '[ _ save-ds-height ] add-instructions ] 2each ] if ;
-: merge-heights ( state predecessors states -- state )
- nip
- [ [ ds-height>> ] map must-equal >>ds-height ]
- [ [ rs-height>> ] map must-equal >>rs-height ] bi ;
+: save-rs-height ( n -- )
+ dup 0 = [ drop ] [ ##inc-r ] if ;
-: insert-peek ( predecessor loc -- vreg )
- ! XXX critical edges
- '[ _ ^^peek ] add-instructions ;
+: merge-rs-heights ( state predecessors states -- state )
+ [ rs-height>> ] map dup all-equal?
+ [ nip first >>rs-height ]
+ [ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
-: merge-loc ( predecessors locs>vregs loc -- vreg )
+: assoc-map-keys ( assoc quot -- assoc' )
+ '[ _ dip ] assoc-map ; inline
+
+: translate-locs ( assoc state -- assoc' )
+ '[ _ translate-loc ] assoc-map-keys ;
+
+: untranslate-locs ( assoc state -- assoc' )
+ '[ _ untranslate-loc ] assoc-map-keys ;
+
+: collect-locs ( loc-maps states -- assoc )
+ ! assoc maps locs to sequences
+ [ untranslate-locs ] 2map
+ [ [ keys ] map concat prune ] keep
+ '[ dup _ [ at ] with map ] H{ } map>assoc ;
+
+: insert-peek ( predecessor loc state -- vreg )
+ '[ _ _ translate-loc ^^peek ] add-instructions ;
+
+SYMBOL: added-phis
+
+: add-phi-later ( inputs -- vreg )
+ [ int-regs next-vreg dup ] dip 2array added-phis get push ;
+
+: merge-loc ( predecessors vregs loc state -- vreg )
! Insert a ##phi in the current block where the input
! is the vreg storing loc from each predecessor block
- [ '[ [ _ ] dip at ] map ] keep
- '[ [ ] [ _ insert-peek ] ?if ] 2map
- dup all-equal? [ first ] [ ^^phi ] if ;
-
-: (merge-locs) ( predecessors assocs -- assoc )
- dup [ keys ] map concat prune
- [ [ 2nip ] [ merge-loc ] 3bi ] with with
- H{ } map>assoc ;
+ '[ [ ] [ _ _ insert-peek ] ?if ] 2map
+ dup all-equal? [ first ] [ add-phi-later ] if ;
-: merge-locs ( state predecessors states -- state )
- [ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
+:: merge-locs ( state predecessors states -- state )
+ states [ locs>vregs>> ] map states collect-locs
+ [| key value |
+ key
+ predecessors value key state merge-loc
+ ] assoc-map
+ state translate-locs
+ state (>>locs>vregs)
+ state ;
-: merge-actual-loc ( locs>vregs loc -- vreg )
- '[ [ _ ] dip at ] map
+: merge-actual-loc ( vregs -- vreg/f )
dup all-equal? [ first ] [ drop f ] if ;
-: merge-actual-locs ( state predecessors states -- state )
- nip
- [ actual-locs>vregs>> ] map
- dup [ keys ] map concat prune
- [ [ nip ] [ merge-actual-loc ] 2bi ] with
- H{ } map>assoc
- [ nip ] assoc-filter
- >>actual-locs>vregs ;
+:: merge-actual-locs ( state states -- state )
+ states [ actual-locs>vregs>> ] map states collect-locs
+ [ merge-actual-loc ] assoc-map [ nip ] assoc-filter
+ state translate-locs
+ state (>>actual-locs>vregs)
+ state ;
-: merge-changed-locs ( state predecessors states -- state )
- nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
+: merge-changed-locs ( state states -- state )
+ [ [ changed-locs>> ] keep untranslate-locs ] map assoc-combine
+ over translate-locs
+ >>changed-locs ;
-ERROR: cannot-merge-poisoned states ;
+:: insert-phis ( bb -- )
+ bb predecessors>> :> predecessors
+ [
+ added-phis get [| dst inputs |
+ dst predecessors inputs zip ##phi
+ ] assoc-each
+ ] V{ } make bb instructions>> over push-all
+ bb (>>instructions) ;
-: multiple-predecessors ( bb states -- state )
- dup [ not ] any? [
- [ <state> ] 2dip
- sift merge-heights
+:: multiple-predecessors ( bb states -- state )
+ states [ not ] any? [
+ <state>
+ bb add-to-work-list
] [
- dup [ poisoned?>> ] any? [
- cannot-merge-poisoned
- ] [
- [ state new ] 2dip
- [ predecessors>> ] dip
- {
- [ merge-locs ]
- [ merge-actual-locs ]
- [ merge-heights ]
- [ merge-changed-locs ]
- } 2cleave
- ] if
+ [
+ H{ } clone added-instructions set
+ V{ } clone added-phis set
+ bb predecessors>> :> predecessors
+ state new
+ predecessors states merge-ds-heights
+ predecessors states merge-rs-heights
+ predecessors states merge-locs
+ states merge-actual-locs
+ states merge-changed-locs
+ bb insert-basic-blocks
+ bb insert-phis
+ ] with-scope
] if ;
: merge-states ( bb states -- state )
- ! If any states are poisoned, save all registers
- ! to the stack in each branch
dup length {
{ 0 [ initial-state ] }
{ 1 [ single-predecessor ] }
[ drop multiple-predecessors ]
- } case ;
\ No newline at end of file
+ } case ;
compiler.cfg.predecessors compiler.cfg.stack-analysis
compiler.cfg.instructions sequences kernel tools.test accessors
sequences.private alien math combinators.private compiler.cfg
-compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo
-compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
-sets namespaces ;
+compiler.cfg.checker compiler.cfg.rpo
+compiler.cfg.dce compiler.cfg.registers
+sets namespaces arrays cpu.architecture ;
IN: compiler.cfg.stack-analysis.tests
! Fundamental invariant: a basic block should not load or store a value more than once
-: check-for-redundant-ops ( cfg -- )
- [
- instructions>>
- [
- [ ##peek? ] filter [ loc>> ] map duplicates empty?
- [ "Redundant peeks" throw ] unless
- ] [
- [ ##replace? ] filter [ loc>> ] map duplicates empty?
- [ "Redundant replaces" throw ] unless
- ] bi
- ] each-basic-block ;
-
: test-stack-analysis ( quot -- cfg )
dup cfg? [ test-cfg first ] unless
compute-predecessors
- delete-useless-blocks
- delete-useless-conditionals
- normalize-height
stack-analysis
- dup check-cfg
- dup check-for-redundant-ops ;
+ dup check-cfg ;
: linearize ( cfg -- mr )
flatten-cfg instructions>> ;
-local-only? off
-
[ ] [ [ ] test-stack-analysis drop ] unit-test
! Only peek once
! Sync before a back-edge, not after
! ##peeks should be inserted before a ##loop-entry
! Don't optimize out the constants
-[ 1 t ] [
+[ t ] [
[ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
- [ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
+ [ ##load-immediate? ] any?
+] unit-test
+
+! Correct height tracking
+[ t ] [
+ [ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
+ reverse-post-order 4 swap nth
+ instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
+ 2array { D 1 D 0 } set=
+] unit-test
+
+[ D 1 ] [
+ V{ T{ ##branch } } 0 test-bb
+
+ V{ T{ ##peek f V int-regs 0 D 2 } T{ ##branch } } 1 test-bb
+
+ V{
+ T{ ##peek f V int-regs 1 D 2 }
+ T{ ##inc-d f -1 }
+ T{ ##branch }
+ } 2 test-bb
+
+ V{ T{ ##call f \ + -1 } T{ ##branch } } 3 test-bb
+
+ V{ T{ ##return } } 4 test-bb
+
+ test-diamond
+
+ cfg new 0 get >>entry
+ compute-predecessors
+ stack-analysis
+ drop
+
+ 3 get successors>> first instructions>> first loc>>
+] unit-test
+
+! Do inserted ##peeks reference the correct stack location if
+! an ##inc-d/r was also inserted?
+[ D 0 ] [
+ V{ T{ ##branch } } 0 test-bb
+
+ V{ T{ ##branch } } 1 test-bb
+
+ V{
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##branch }
+ } 2 test-bb
+
+ V{
+ T{ ##call f \ + -1 }
+ T{ ##inc-d f 1 }
+ T{ ##branch }
+ } 3 test-bb
+
+ V{ T{ ##return } } 4 test-bb
+
+ test-diamond
+
+ cfg new 0 get >>entry
+ compute-predecessors
+ stack-analysis
+ drop
+
+ 3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
+] unit-test
+
+! Missing ##replace
+[ t ] [
+ [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
+ reverse-post-order last
+ instructions>> [ ##replace? ] filter [ loc>> ] map
+ { D 0 D 1 D 2 } set=
+] unit-test
+
+! Inserted ##peeks reference the wrong stack location
+[ t ] [
+ [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis
+ eliminate-dead-code reverse-post-order 4 swap nth
+ instructions>> [ ##peek? ] filter [ loc>> ] map
+ { D 0 D 1 } set=
] unit-test
+
+[ D 0 ] [
+ V{ T{ ##branch } } 0 test-bb
+
+ V{ T{ ##branch } } 1 test-bb
+
+ V{
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##inc-d f 1 }
+ T{ ##branch }
+ } 2 test-bb
+
+ V{
+ T{ ##inc-d f 1 }
+ T{ ##branch }
+ } 3 test-bb
+
+ V{ T{ ##return } } 4 test-bb
+
+ test-diamond
+
+ cfg new 0 get >>entry
+ compute-predecessors
+ stack-analysis
+ drop
+
+ 3 get successors>> first instructions>> [ ##peek? ] find nip loc>>
+] unit-test
\ No newline at end of file
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel namespaces math sequences fry grouping
-sets make combinators
+sets make combinators dlists deques
compiler.cfg
compiler.cfg.copy-prop
compiler.cfg.def-use
compiler.cfg.rpo
compiler.cfg.hats
compiler.cfg.stack-analysis.state
-compiler.cfg.stack-analysis.merge ;
+compiler.cfg.stack-analysis.merge
+compiler.cfg.utilities ;
IN: compiler.cfg.stack-analysis
-! Convert stack operations to register operations
-GENERIC: height-for ( loc -- n )
-
-M: ds-loc height-for drop state get ds-height>> ;
-M: rs-loc height-for drop state get rs-height>> ;
-
-: (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline
-
-GENERIC: translate-loc ( loc -- loc' )
-
-M: ds-loc translate-loc (translate-loc) - <ds-loc> ;
-M: rs-loc translate-loc (translate-loc) - <rs-loc> ;
-
-GENERIC: untranslate-loc ( loc -- loc' )
-
-M: ds-loc untranslate-loc (translate-loc) + <ds-loc> ;
-M: rs-loc untranslate-loc (translate-loc) + <rs-loc> ;
+SYMBOL: global-optimization?
: redundant-replace? ( vreg loc -- ? )
- dup untranslate-loc n>> 0 <
+ dup state get untranslate-loc n>> 0 <
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
: save-changed-locs ( state -- )
- [ changed-locs>> ] [ locs>vregs>> ] bi '[
- _ at swap 2dup redundant-replace?
- [ 2drop ] [ untranslate-loc ##replace ] if
- ] assoc-each ;
+ [ changed-locs>> keys ] [ locs>vregs>> ] bi '[
+ dup _ at swap 2dup redundant-replace?
+ [ 2drop ] [ state get untranslate-loc ##replace ] if
+ ] each ;
ERROR: poisoned-state state ;
: sync-state ( -- )
state get {
[ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
+ [ ds-height>> save-ds-height ]
+ [ rs-height>> save-rs-height ]
[ save-changed-locs ]
[ clear-state ]
} cleave ;
! Abstract interpretation
GENERIC: visit ( insn -- )
-: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ;
-
-M: ##inc-d visit [ , ] [ n>> adjust-ds ] bi ;
-
-: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;
+M: ##inc-d visit
+ n>> state get [ + ] change-ds-height drop ;
-M: ##inc-r visit [ , ] [ n>> adjust-rs ] bi ;
+M: ##inc-r visit
+ n>> state get [ + ] change-rs-height drop ;
! Instructions which don't have any effect on the stack
UNION: neutral-insn
+ ##effect
##flushable
- ##effect ;
+ ##no-tco ;
M: neutral-insn visit , ;
##conditional-branch
##compare-imm-branch
##dispatch
- ##loop-entry ;
-
-SYMBOL: local-only?
-
-t local-only? set-global
-
-: back-edge? ( from to -- ? )
- [ number>> ] bi@ > ;
+ ##loop-entry
+ ##fixnum-overflow ;
: sync-state? ( -- ? )
basic-block get successors>>
- [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any?
- local-only? get or ;
+ [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ;
M: sync-if-back-edge visit
- sync-state? [ sync-state ] when , ;
+ global-optimization? get [ sync-state? [ sync-state ] when ] unless
+ , ;
: eliminate-peek ( dst src -- )
! the requested stack location is already in 'src'
[ ##copy ] [ swap copies get set-at ] 2bi ;
M: ##peek visit
- dup
- [ dst>> ] [ loc>> translate-loc ] bi
- dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ;
+ [ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg
+ [ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ;
M: ##replace visit
- [ src>> resolve ] [ loc>> translate-loc ] bi
+ [ src>> resolve ] [ loc>> state get translate-loc ] bi
record-replace ;
M: ##copy visit
[ call-next-method ] [ record-copy ] bi ;
-M: ##call visit
- [ call-next-method ] [ height>> adjust-ds ] bi ;
-
-! Instructions that poison the stack state
-UNION: poison-insn
- ##jump
- ##return
- ##callback-return
- ##fixnum-mul-tail
- ##fixnum-add-tail
- ##fixnum-sub-tail ;
-
M: poison-insn visit call-next-method poison-state ;
-! Instructions that kill all live vregs
-UNION: kill-vreg-insn
- poison-insn
- ##stack-frame
- ##call
- ##prologue
- ##epilogue
- ##fixnum-mul
- ##fixnum-add
- ##fixnum-sub
- ##alien-invoke
- ##alien-indirect ;
-
M: kill-vreg-insn visit sync-state , ;
-: visit-alien-node ( node -- )
- params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-ds ;
-
-M: ##alien-invoke visit
- [ call-next-method ] [ visit-alien-node ] bi ;
-
-M: ##alien-indirect visit
- [ call-next-method ] [ visit-alien-node ] bi ;
-
-M: ##alien-callback visit , ;
-
! Maps basic-blocks to states
-SYMBOLS: state-in state-out ;
+SYMBOL: state-out
: block-in-state ( bb -- states )
dup predecessors>> state-out get '[ _ at ] map merge-states ;
-: set-block-in-state ( state bb -- )
- [ clone ] dip state-in get set-at ;
-
: set-block-out-state ( state bb -- )
[ clone ] dip state-out get set-at ;
[
dup basic-block set
dup block-in-state
- [ swap set-block-in-state ] [
- state [
- [ instructions>> [ visit ] each ]
- [ [ state get ] dip set-block-out-state ]
- [ ]
- tri
- ] with-variable
- ] 2bi
+ state [
+ [ instructions>> [ visit ] each ]
+ [ [ state get ] dip set-block-out-state ]
+ [ ]
+ tri
+ ] with-variable
] V{ } make >>instructions drop ;
: stack-analysis ( cfg -- cfg' )
[
+ <hashed-dlist> work-list set
H{ } clone copies set
- H{ } clone state-in set
H{ } clone state-out set
dup [ visit-block ] each-basic-block
+ global-optimization? get [ work-list get [ visit-block ] slurp-deque ] when
+ cfg-changed
] with-scope ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces assocs sets math ;
+USING: kernel accessors namespaces assocs sets math deques
+compiler.cfg.registers ;
IN: compiler.cfg.stack-analysis.state
TUPLE: state
locs>vregs actual-locs>vregs changed-locs
-ds-height rs-height poisoned? ;
+{ ds-height integer }
+{ rs-height integer }
+poisoned? ;
: <state> ( -- state )
state new
dup changed-loc state get locs>vregs>> set-at ;
: clear-state ( state -- )
- [ locs>vregs>> clear-assoc ]
- [ actual-locs>vregs>> clear-assoc ]
- [ changed-locs>> clear-assoc ]
- tri ;
+ 0 >>ds-height 0 >>rs-height
+ [ locs>vregs>> ] [ actual-locs>vregs>> ] [ changed-locs>> ] tri
+ [ clear-assoc ] tri@ ;
-: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ;
+GENERIC# translate-loc 1 ( loc state -- loc' )
+M: ds-loc translate-loc [ n>> ] [ ds-height>> ] bi* - <ds-loc> ;
+M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - <rs-loc> ;
-: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;
+GENERIC# untranslate-loc 1 ( loc state -- loc' )
+M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + <ds-loc> ;
+M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + <rs-loc> ;
+
+SYMBOL: work-list
+
+: add-to-work-list ( bb -- ) work-list get push-front ;
: gc-root-offset ( n -- n' ) gc-root-base + ;
-: gc-roots-size ( live-registers live-spill-slots -- n )
- [ keys [ reg-class>> reg-size ] sigma ] bi@ + ;
+: gc-roots-size ( live-values -- n )
+ keys [ reg-class>> reg-size ] sigma ;
: (stack-frame-size) ( stack-frame -- n )
[
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators.short-circuit kernel math
+namespaces sequences fry combinators
+compiler.utilities
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.hats
+compiler.cfg.instructions
+compiler.cfg.utilities ;
+IN: compiler.cfg.tco
+
+! Tail call optimization. You must run compute-predecessors after this
+
+: return? ( bb -- ? )
+ skip-empty-blocks
+ instructions>> {
+ [ length 2 = ]
+ [ first ##epilogue? ]
+ [ second ##return? ]
+ } 1&& ;
+
+: tail-call? ( bb -- ? )
+ {
+ [ instructions>> { [ length 2 >= ] [ last ##branch? ] } 1&& ]
+ [ successors>> first return? ]
+ } 1&& ;
+
+: word-tail-call? ( bb -- ? )
+ instructions>> penultimate ##call? ;
+
+: convert-tail-call ( bb quot: ( insn -- tail-insn ) -- )
+ '[
+ instructions>>
+ [ pop* ] [ pop ] [ ] tri
+ [ [ \ ##epilogue new-insn ] dip push ]
+ [ _ dip push ] bi
+ ]
+ [ successors>> delete-all ]
+ bi ; inline
+
+: convert-word-tail-call ( bb -- )
+ [ word>> \ ##jump new-insn ] convert-tail-call ;
+
+: loop-tail-call? ( bb -- ? )
+ instructions>> penultimate
+ { [ ##call? ] [ word>> cfg get label>> eq? ] } 1&& ;
+
+: convert-loop-tail-call ( bb -- )
+ ! If a word calls itself, this becomes a loop in the CFG.
+ [ instructions>> [ pop* ] [ pop* ] [ [ \ ##branch new-insn ] dip push ] tri ]
+ [ successors>> delete-all ]
+ [ [ cfg get entry>> successors>> first ] dip successors>> push ]
+ tri ;
+
+: optimize-tail-call ( bb -- )
+ dup tail-call? [
+ {
+ { [ dup loop-tail-call? ] [ convert-loop-tail-call ] }
+ { [ dup word-tail-call? ] [ convert-word-tail-call ] }
+ [ drop ]
+ } cond
+ ] [ drop ] if ;
+
+: optimize-tail-calls ( cfg -- cfg' )
+ dup cfg set
+ dup [ optimize-tail-call ] each-basic-block
+ cfg-changed ;
\ No newline at end of file
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences make compiler.cfg.instructions
-compiler.cfg.local cpu.architecture ;
+compiler.cfg.rpo cpu.architecture ;
IN: compiler.cfg.two-operand
! On x86, instructions take the form x = x op y
! since x86 has LEA and IMUL instructions which are effectively
! three-operand addition and multiplication, respectively.
-: make-copy ( dst src -- insn ) \ ##copy new-insn ; inline
-
-: make-copy/float ( dst src -- insn ) \ ##copy-float new-insn ; inline
-
: convert-two-operand/integer ( insn -- )
[ [ dst>> ] [ src1>> ] bi ##copy ]
[ dup dst>> >>src1 , ]
M: ##or-imm convert-two-operand* convert-two-operand/integer ;
M: ##xor convert-two-operand* convert-two-operand/integer ;
M: ##xor-imm convert-two-operand* convert-two-operand/integer ;
+M: ##shl convert-two-operand* convert-two-operand/integer ;
M: ##shl-imm convert-two-operand* convert-two-operand/integer ;
+M: ##shr convert-two-operand* convert-two-operand/integer ;
M: ##shr-imm convert-two-operand* convert-two-operand/integer ;
+M: ##sar convert-two-operand* convert-two-operand/integer ;
M: ##sar-imm convert-two-operand* convert-two-operand/integer ;
+M: ##fixnum-overflow convert-two-operand* convert-two-operand/integer ;
+
M: ##add-float convert-two-operand* convert-two-operand/float ;
M: ##sub-float convert-two-operand* convert-two-operand/float ;
M: ##mul-float convert-two-operand* convert-two-operand/float ;
: convert-two-operand ( cfg -- cfg' )
two-operand? [
- [ drop ]
[ [ [ convert-two-operand* ] each ] V{ } make ]
local-optimization
] when ;
+++ /dev/null
-Eliminating unreachable basic blocks and unconditional jumps
+++ /dev/null
-IN: compiler.cfg.useless-blocks.tests
-USING: fry kernel sequences compiler.cfg.useless-blocks compiler.cfg.checker
-compiler.cfg.debugger compiler.cfg.predecessors tools.test ;
-
-{
- [ [ drop 1 ] when ]
- [ [ drop 1 ] unless ]
-} [
- [ [ ] ] dip
- '[ _ test-cfg first compute-predecessors delete-useless-blocks check-cfg ] unit-test
-] each
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences combinators combinators.short-circuit
-classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
-IN: compiler.cfg.useless-blocks
-
-: update-predecessor-for-delete ( bb -- )
- ! We have to replace occurrences of bb with bb's successor
- ! in bb's predecessor's list of successors.
- dup predecessors>> first [
- [
- 2dup eq? [ drop successors>> first ] [ nip ] if
- ] with map
- ] change-successors drop ;
-
-: update-successor-for-delete ( bb -- )
- ! We have to replace occurrences of bb with bb's predecessor
- ! in bb's sucessor's list of predecessors.
- dup successors>> first [
- [
- 2dup eq? [ drop predecessors>> first ] [ nip ] if
- ] with map
- ] change-predecessors drop ;
-
-: delete-basic-block ( bb -- )
- [ update-predecessor-for-delete ]
- [ update-successor-for-delete ]
- bi ;
-
-: delete-basic-block? ( bb -- ? )
- {
- [ instructions>> length 1 = ]
- [ predecessors>> length 1 = ]
- [ successors>> length 1 = ]
- [ instructions>> first ##branch? ]
- } 1&& ;
-
-: delete-useless-blocks ( cfg -- cfg' )
- dup [
- dup delete-basic-block? [ delete-basic-block ] [ drop ] if
- ] each-basic-block
- f >>post-order ;
-
-: delete-conditional? ( bb -- ? )
- dup instructions>> [ drop f ] [
- last class {
- ##compare-branch
- ##compare-imm-branch
- ##compare-float-branch
- } memq? [ successors>> first2 eq? ] [ drop f ] if
- ] if-empty ;
-
-: delete-conditional ( bb -- )
- dup successors>> first 1vector >>successors
- [ but-last \ ##branch new-insn suffix ] change-instructions
- drop ;
-
-: delete-useless-conditionals ( cfg -- cfg' )
- dup [
- dup delete-conditional? [ delete-conditional ] [ drop ] if
- ] each-basic-block
- f >>post-order ;
--- /dev/null
+Eliminating unreachable basic blocks and unconditional jumps
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences math combinators combinators.short-circuit
+classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.utilities ;
+IN: compiler.cfg.useless-conditionals
+
+: delete-conditional? ( bb -- ? )
+ {
+ [ instructions>> last class { ##compare-branch ##compare-imm-branch ##compare-float-branch } memq? ]
+ [ successors>> first2 [ skip-empty-blocks ] bi@ eq? ]
+ } 1&& ;
+
+: delete-conditional ( bb -- )
+ [ first skip-empty-blocks 1vector ] change-successors
+ instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ;
+
+: delete-useless-conditionals ( cfg -- cfg' )
+ dup [
+ dup delete-conditional? [ delete-conditional ] [ drop ] if
+ ] each-basic-block
+ cfg-changed ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math layouts make sequences combinators
-cpu.architecture namespaces compiler.cfg
-compiler.cfg.instructions ;
+USING: accessors assocs combinators combinators.short-circuit
+compiler.cfg compiler.cfg.instructions cpu.architecture kernel
+layouts locals make math namespaces sequences sets vectors fry ;
IN: compiler.cfg.utilities
: value-info-small-fixnum? ( value-info -- ? )
building off
basic-block off ;
-: stop-iterating ( -- next ) end-basic-block f ;
+: emit-primitive ( node -- )
+ word>> ##call ##branch begin-basic-block ;
-: call-height ( ##call -- n )
- [ out-d>> length ] [ in-d>> length ] bi - ;
+: with-branch ( quot -- final-bb )
+ [
+ begin-basic-block
+ call
+ basic-block get dup [ ##branch ] when
+ ] with-scope ; inline
-: emit-primitive ( node -- )
- [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ;
+: emit-conditional ( branches -- )
+ end-basic-block
+ begin-basic-block
+ basic-block get '[ [ _ swap successors>> push ] when* ] each ;
+
+: back-edge? ( from to -- ? )
+ [ number>> ] bi@ >= ;
+
+: empty-block? ( bb -- ? )
+ instructions>> {
+ [ length 1 = ]
+ [ first ##branch? ]
+ } 1&& ;
+
+SYMBOL: visited
+
+: (skip-empty-blocks) ( bb -- bb' )
+ dup visited get key? [
+ dup empty-block? [
+ dup visited get conjoin
+ successors>> first (skip-empty-blocks)
+ ] when
+ ] unless ;
+
+: skip-empty-blocks ( bb -- bb' )
+ H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
+
+! assoc mapping predecessors to sequences
+SYMBOL: added-instructions
+
+: add-instructions ( predecessor quot -- )
+ [
+ added-instructions get
+ [ drop V{ } clone ] cache
+ building
+ ] dip with-variable ; inline
+
+:: insert-basic-block ( from to bb -- )
+ bb from 1vector >>predecessors drop
+ bb to 1vector >>successors drop
+ to predecessors>> [ dup from eq? [ drop bb ] when ] change-each
+ from successors>> [ dup to eq? [ drop bb ] when ] change-each ;
+
+: <simple-block> ( insns -- bb )
+ <basic-block>
+ swap >vector
+ \ ##branch new-insn over push
+ >>instructions ;
+
+: insert-basic-blocks ( bb -- )
+ [ added-instructions get ] dip
+ '[ [ _ ] dip <simple-block> insert-basic-block ] assoc-each ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes kernel math namespaces combinators
-compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
+combinators.short-circuit compiler.cfg.instructions
+compiler.cfg.value-numbering.graph ;
IN: compiler.cfg.value-numbering.expressions
! Referentially-transparent expressions
-TUPLE: expr op ;
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 ;
: <constant> ( constant -- expr )
f swap constant-expr boa ; inline
M: constant-expr equal?
over constant-expr? [
- [ [ value>> ] bi@ = ]
- [ [ value>> class ] bi@ = ] 2bi
- and
+ {
+ [ [ value>> class ] bi@ = ]
+ [ [ value>> ] bi@ = ]
+ } 2&&
] [ 2drop f ] if ;
-! Expressions whose values are inputs to the basic block. We
-! can eliminate a second computation having the same 'n' as
-! the first one; we can also eliminate input-exprs whose
-! result is not used.
-TUPLE: input-expr < expr n ;
+: <reference> ( constant -- expr )
+ f swap reference-expr boa ; inline
-SYMBOL: input-expr-counter
-
-: next-input-expr ( class -- expr )
- input-expr-counter [ dup 1 + ] change input-expr boa ;
+M: reference-expr equal?
+ over reference-expr? [
+ [ value>> ] bi@ {
+ { [ 2dup eq? ] [ 2drop t ] }
+ { [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
+ [ 2drop f ]
+ } cond
+ ] [ 2drop f ] if ;
: constant>vn ( constant -- vn ) <constant> expr>vn ; inline
M: ##load-immediate >expr val>> <constant> ;
+M: ##load-reference >expr obj>> <reference> ;
+
M: ##unary >expr
[ class ] [ src>> vreg>vn ] bi unary-expr boa ;
M: ##compare-float >expr compare>expr ;
-M: ##flushable >expr class next-input-expr ;
+M: ##flushable >expr drop next-input-expr ;
: init-expressions ( -- )
0 input-expr-counter set ;
! biassoc mapping expressions to value numbers
SYMBOL: exprs>vns
+TUPLE: expr op ;
+
: expr>vn ( expr -- vn ) exprs>vns get [ drop next-vn ] cache ;
: vn>expr ( vn -- expr ) exprs>vns get value-at ;
+! Expressions whose values are inputs to the basic block.
+TUPLE: input-expr < expr n ;
+
+SYMBOL: input-expr-counter
+
+: next-input-expr ( -- expr )
+ f input-expr-counter counter input-expr boa ;
+
SYMBOL: vregs>vns
-: vreg>vn ( vreg -- vn ) vregs>vns get at ;
+: vreg>vn ( vreg -- vn )
+ vregs>vns get [ drop next-input-expr expr>vn ] cache ;
: vn>vreg ( vn -- vreg ) vregs>vns get value-at ;
: vn>constant ( vn -- constant ) vn>expr value>> ; inline
+: vreg>constant ( vreg -- constant ) vreg>vn vn>constant ; inline
+
: init-value-graph ( -- )
0 vn-counter set
<bihash> exprs>vns set
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs sequences kernel accessors
-compiler.cfg.instructions compiler.cfg.value-numbering.graph ;
-IN: compiler.cfg.value-numbering.propagate
-
-! If two vregs compute the same value, replace references to
-! the latter with the former.
-
-: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ; inline
-
-GENERIC: propagate ( insn -- insn )
-
-M: ##effect propagate
- [ resolve ] change-src ;
-
-M: ##unary propagate
- [ resolve ] change-src ;
-
-M: ##binary propagate
- [ resolve ] change-src1
- [ resolve ] change-src2 ;
-
-M: ##binary-imm propagate
- [ resolve ] change-src1 ;
-
-M: ##slot propagate
- [ resolve ] change-obj
- [ resolve ] change-slot ;
-
-M: ##slot-imm propagate
- [ resolve ] change-obj ;
-
-M: ##set-slot propagate
- call-next-method
- [ resolve ] change-obj
- [ resolve ] change-slot ;
-
-M: ##string-nth propagate
- [ resolve ] change-obj
- [ resolve ] change-index ;
-
-M: ##set-slot-imm propagate
- call-next-method
- [ resolve ] change-obj ;
-
-M: ##alien-getter propagate
- call-next-method
- [ resolve ] change-src ;
-
-M: ##alien-setter propagate
- call-next-method
- [ resolve ] change-value ;
-
-M: ##conditional-branch propagate
- [ resolve ] change-src1
- [ resolve ] change-src2 ;
-
-M: ##compare-imm-branch propagate
- [ resolve ] change-src1 ;
-
-M: ##dispatch propagate
- [ resolve ] change-src ;
-
-M: ##fixnum-overflow propagate
- [ resolve ] change-src1
- [ resolve ] change-src2 ;
-
-M: insn propagate ;
+++ /dev/null
-Propagation pass to update code after value numbering
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences layouts accessors combinators namespaces
-math fry
+USING: accessors combinators combinators.short-circuit arrays
+fry kernel layouts math namespaces sequences cpu.architecture
+math.bitwise math.order classes vectors
+compiler.cfg
compiler.cfg.hats
+compiler.cfg.comparisons
compiler.cfg.instructions
+compiler.cfg.value-numbering.expressions
compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.simplify
-compiler.cfg.value-numbering.expressions ;
+compiler.cfg.value-numbering.simplify ;
IN: compiler.cfg.value-numbering.rewrite
-GENERIC: rewrite ( insn -- insn' )
+: vreg-small-constant? ( vreg -- ? )
+ vreg>expr {
+ [ constant-expr? ]
+ [ value>> small-enough? ]
+ } 1&& ;
-M: ##mul-imm rewrite
- dup src2>> dup power-of-2? [
- [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn
- dup number-values
- ] [ drop ] if ;
+! Outputs f to mean no change
+
+GENERIC: rewrite* ( insn -- insn/f )
+
+: rewrite ( insn -- insn' )
+ dup [ number-values ] [ rewrite* ] bi
+ [ rewrite ] [ ] ?if ;
+
+M: insn rewrite* drop f ;
: ##branch-t? ( insn -- ? )
dup ##compare-imm-branch? [
- [ cc>> cc/= eq? ]
- [ src2>> \ f tag-number eq? ] bi and
+ {
+ [ cc>> cc/= eq? ]
+ [ src2>> \ f tag-number eq? ]
+ } 1&&
] [ drop f ] if ; inline
: rewrite-boolean-comparison? ( insn -- ? )
: rewrite-tagged-comparison? ( insn -- ? )
#! Are we comparing two tagged fixnums? Then untag them.
- [ src1>> vreg>expr tag-fixnum-expr? ]
- [ src2>> tag-mask get bitand 0 = ]
- bi and ; inline
+ {
+ [ src1>> vreg>expr tag-fixnum-expr? ]
+ [ src2>> tag-mask get bitand 0 = ]
+ } 1&& ; inline
+
+: tagged>constant ( n -- n' )
+ tag-bits get neg shift ; inline
: (rewrite-tagged-comparison) ( insn -- src1 src2 cc )
[ src1>> vreg>expr in1>> vn>vreg ]
- [ src2>> tag-bits get neg shift ]
+ [ src2>> tagged>constant ]
[ cc>> ]
tri ; inline
-GENERIC: rewrite-tagged-comparison ( insn -- insn' )
+GENERIC: rewrite-tagged-comparison ( insn -- insn/f )
M: ##compare-imm-branch rewrite-tagged-comparison
(rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ;
[ dst>> ] [ (rewrite-tagged-comparison) ] bi
i \ ##compare-imm new-insn ;
-M: ##compare-imm-branch rewrite
- dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when
- dup ##compare-imm-branch? [
- dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when
- ] when ;
-
-: flip-comparison? ( insn -- ? )
- dup cc>> cc= eq? [ src1>> vreg>expr constant-expr? ] [ drop f ] if ;
-
-: flip-comparison ( insn -- insn' )
- [ dst>> ]
- [ src2>> ]
- [ src1>> vreg>vn vn>constant ] tri
- cc= i \ ##compare-imm new-insn ;
-
-M: ##compare rewrite
- dup flip-comparison? [
- flip-comparison
- dup number-values
- rewrite
- ] when ;
-
: rewrite-redundant-comparison? ( insn -- ? )
- [ src1>> vreg>expr compare-expr? ]
- [ src2>> \ f tag-number = ]
- [ cc>> { cc= cc/= } memq? ]
- tri and and ; inline
+ {
+ [ src1>> vreg>expr 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 {
} case
swap cc= eq? [ [ negate-cc ] change-cc ] when ;
-M: ##compare-imm rewrite
- dup rewrite-redundant-comparison? [
- rewrite-redundant-comparison
- dup number-values rewrite
- ] when
- dup ##compare-imm? [
- dup rewrite-tagged-comparison? [
- rewrite-tagged-comparison
- dup number-values rewrite
- ] when
- ] when ;
-
-M: insn rewrite ;
+ERROR: bad-comparison ;
+
+: (fold-compare-imm) ( insn -- ? )
+ [ [ src1>> vreg>constant ] [ src2>> ] bi ] [ cc>> ] bi
+ pick integer?
+ [ [ <=> ] dip evaluate-cc ]
+ [
+ 2nip {
+ { cc= [ f ] }
+ { cc/= [ t ] }
+ [ bad-comparison ]
+ } case
+ ] if ;
+
+: fold-compare-imm? ( insn -- ? )
+ src1>> vreg>expr [ constant-expr? ] [ reference-expr? ] bi or ;
+
+: fold-branch ( ? -- insn )
+ 0 1 ?
+ basic-block get [ nth 1vector ] change-successors drop
+ \ ##branch new-insn ;
+
+: fold-compare-imm-branch ( insn -- insn/f )
+ (fold-compare-imm) fold-branch ;
+
+M: ##compare-imm-branch rewrite*
+ {
+ { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
+ { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
+ { [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] }
+ [ drop f ]
+ } cond ;
+
+: swap-compare ( src1 src2 cc swap? -- src1 src2 cc )
+ [ [ swap ] dip swap-cc ] when ; inline
+
+: >compare-imm-branch ( insn swap? -- insn' )
+ [
+ [ src1>> ]
+ [ src2>> ]
+ [ cc>> ]
+ tri
+ ] dip
+ swap-compare
+ [ vreg>constant ] dip
+ \ ##compare-imm-branch new-insn ; inline
+
+: self-compare? ( insn -- ? )
+ [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline
+
+: (rewrite-self-compare) ( insn -- ? )
+ cc>> { cc= cc<= cc>= } memq? ;
+
+: rewrite-self-compare-branch ( insn -- insn' )
+ (rewrite-self-compare) fold-branch ;
+
+M: ##compare-branch rewrite*
+ {
+ { [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] }
+ { [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] }
+ { [ dup self-compare? ] [ rewrite-self-compare-branch ] }
+ [ drop f ]
+ } cond ;
+
+: >compare-imm ( insn swap? -- insn' )
+ [
+ {
+ [ dst>> ]
+ [ src1>> ]
+ [ src2>> ]
+ [ cc>> ]
+ } cleave
+ ] dip
+ swap-compare
+ [ vreg>constant ] dip
+ i \ ##compare-imm new-insn ; inline
+
+: >boolean-insn ( insn ? -- insn' )
+ [ dst>> ] dip
+ {
+ { t [ t \ ##load-reference new-insn ] }
+ { f [ \ f tag-number \ ##load-immediate new-insn ] }
+ } case ;
+
+: rewrite-self-compare ( insn -- insn' )
+ dup (rewrite-self-compare) >boolean-insn ;
+
+M: ##compare rewrite*
+ {
+ { [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] }
+ { [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] }
+ { [ dup self-compare? ] [ rewrite-self-compare ] }
+ [ drop f ]
+ } cond ;
+
+: fold-compare-imm ( insn -- insn' )
+ dup (fold-compare-imm) >boolean-insn ;
+
+M: ##compare-imm rewrite*
+ {
+ { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
+ { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
+ { [ dup fold-compare-imm? ] [ fold-compare-imm ] }
+ [ drop f ]
+ } cond ;
+
+: constant-fold? ( insn -- ? )
+ src1>> vreg>expr constant-expr? ; inline
+
+GENERIC: constant-fold* ( x y insn -- z )
+
+M: ##add-imm constant-fold* drop + ;
+M: ##sub-imm constant-fold* drop - ;
+M: ##mul-imm constant-fold* drop * ;
+M: ##and-imm constant-fold* drop bitand ;
+M: ##or-imm constant-fold* drop bitor ;
+M: ##xor-imm constant-fold* drop bitxor ;
+M: ##shr-imm constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ;
+M: ##sar-imm constant-fold* drop neg shift ;
+M: ##shl-imm constant-fold* drop shift ;
+
+: constant-fold ( insn -- insn' )
+ [ dst>> ]
+ [ [ 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 ]
+ [ src2>> ]
+ [ ]
+ } cleave constant-fold*
+ ] dip
+ over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline
+
+M: ##add-imm rewrite*
+ {
+ { [ dup constant-fold? ] [ constant-fold ] }
+ { [ dup reassociate? ] [ \ ##add-imm reassociate ] }
+ [ drop f ]
+ } cond ;
+
+: sub-imm>add-imm ( insn -- insn' )
+ [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough?
+ [ \ ##add-imm new-insn ] [ 3drop f ] if ;
+
+M: ##sub-imm rewrite*
+ {
+ { [ dup constant-fold? ] [ constant-fold ] }
+ [ sub-imm>add-imm ]
+ } cond ;
+
+: strength-reduce-mul ( insn -- insn' )
+ [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ;
+
+: strength-reduce-mul? ( insn -- ? )
+ src2>> power-of-2? ;
+
+M: ##mul-imm rewrite*
+ {
+ { [ dup constant-fold? ] [ constant-fold ] }
+ { [ dup strength-reduce-mul? ] [ strength-reduce-mul ] }
+ { [ dup reassociate? ] [ \ ##mul-imm reassociate ] }
+ [ drop f ]
+ } cond ;
+
+M: ##and-imm rewrite*
+ {
+ { [ dup constant-fold? ] [ constant-fold ] }
+ { [ dup reassociate? ] [ \ ##and-imm reassociate ] }
+ [ drop f ]
+ } cond ;
+
+M: ##or-imm rewrite*
+ {
+ { [ dup constant-fold? ] [ constant-fold ] }
+ { [ dup reassociate? ] [ \ ##or-imm reassociate ] }
+ [ drop f ]
+ } cond ;
+
+M: ##xor-imm rewrite*
+ {
+ { [ dup constant-fold? ] [ constant-fold ] }
+ { [ dup reassociate? ] [ \ ##xor-imm reassociate ] }
+ [ drop f ]
+ } cond ;
+
+M: ##shl-imm rewrite*
+ {
+ { [ dup constant-fold? ] [ constant-fold ] }
+ [ drop f ]
+ } cond ;
+
+M: ##shr-imm rewrite*
+ {
+ { [ dup constant-fold? ] [ constant-fold ] }
+ [ drop f ]
+ } cond ;
+
+M: ##sar-imm rewrite*
+ {
+ { [ dup constant-fold? ] [ constant-fold ] }
+ [ drop f ]
+ } cond ;
+
+: insn>imm-insn ( insn op swap? -- )
+ swap [
+ [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip
+ [ swap ] when vreg>constant
+ ] dip new-insn ; inline
+
+: rewrite-arithmetic ( insn op -- ? )
+ {
+ { [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] }
+ [ 2drop f ]
+ } cond ; inline
+
+: rewrite-arithmetic-commutative ( insn op -- ? )
+ {
+ { [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] }
+ { [ over src1>> vreg-small-constant? ] [ t insn>imm-insn ] }
+ [ 2drop f ]
+ } cond ; inline
+
+M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ;
+
+: subtraction-identity? ( insn -- ? )
+ [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq? ;
+
+: rewrite-subtraction-identity ( insn -- insn' )
+ dst>> 0 \ ##load-immediate new-insn ;
+
+M: ##sub rewrite*
+ {
+ { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
+ [ \ ##sub-imm rewrite-arithmetic ]
+ } cond ;
+
+M: ##mul rewrite* \ ##mul-imm rewrite-arithmetic-commutative ;
+
+M: ##and rewrite* \ ##and-imm rewrite-arithmetic-commutative ;
+
+M: ##or rewrite* \ ##or-imm rewrite-arithmetic-commutative ;
+
+M: ##xor rewrite* \ ##xor-imm rewrite-arithmetic-commutative ;
+
+M: ##shl rewrite* \ ##shl-imm rewrite-arithmetic ;
+
+M: ##shr rewrite* \ ##shr-imm rewrite-arithmetic ;
+
+M: ##sar rewrite* \ ##sar-imm rewrite-arithmetic ;
USING: kernel accessors combinators classes math layouts
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
-compiler.cfg.value-numbering.expressions ;
+compiler.cfg.value-numbering.expressions locals ;
IN: compiler.cfg.value-numbering.simplify
! Return value of f means we didn't simplify.
: expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline
+: expr-one? ( expr -- ? ) T{ constant-expr f f 1 } = ; inline
+
: >binary-expr< ( expr -- in1 in2 )
[ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline
[ 2drop f ]
} cond ; inline
-: useless-shift? ( in1 in2 -- ? )
+: simplify-sub ( expr -- vn/expr/f )
+ >binary-expr< {
+ { [ dup expr-zero? ] [ drop ] }
+ [ 2drop f ]
+ } cond ; inline
+
+: simplify-mul ( expr -- vn/expr/f )
+ >binary-expr< {
+ { [ over expr-one? ] [ drop ] }
+ { [ dup expr-one? ] [ drop ] }
+ [ 2drop f ]
+ } cond ; inline
+
+: simplify-and ( expr -- vn/expr/f )
+ >binary-expr< {
+ { [ 2dup eq? ] [ drop ] }
+ [ 2drop f ]
+ } cond ; inline
+
+: simplify-or ( expr -- vn/expr/f )
+ >binary-expr< {
+ { [ 2dup eq? ] [ drop ] }
+ { [ over expr-zero? ] [ nip ] }
+ { [ dup expr-zero? ] [ drop ] }
+ [ 2drop f ]
+ } cond ; inline
+
+: simplify-xor ( expr -- vn/expr/f )
+ >binary-expr< {
+ { [ over expr-zero? ] [ nip ] }
+ { [ dup expr-zero? ] [ drop ] }
+ [ 2drop f ]
+ } cond ; inline
+
+: useless-shr? ( in1 in2 -- ? )
over op>> \ ##shl-imm eq?
[ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline
-: simplify-shift ( expr -- vn/expr/f )
- >binary-expr<
- 2dup useless-shift? [ drop in1>> ] [ 2drop f ] if ; inline
+: simplify-shr ( expr -- vn/expr/f )
+ >binary-expr< {
+ { [ 2dup useless-shr? ] [ drop in1>> ] }
+ { [ dup expr-zero? ] [ drop ] }
+ [ 2drop f ]
+ } cond ; inline
+
+: 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 ] }
- { \ ##shr-imm [ simplify-shift ] }
- { \ ##sar-imm [ simplify-shift ] }
+ { \ ##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 ;
IN: compiler.cfg.value-numbering.tests
USING: compiler.cfg.value-numbering compiler.cfg.instructions
-compiler.cfg.registers compiler.cfg.debugger cpu.architecture
-tools.test kernel math combinators.short-circuit accessors
-sequences compiler.cfg vectors arrays ;
+compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
+cpu.architecture tools.test kernel math combinators.short-circuit
+accessors sequences compiler.cfg.predecessors locals
+compiler.cfg.phi-elimination compiler.cfg.dce
+compiler.cfg assocs vectors arrays layouts namespaces ;
: trim-temps ( insns -- insns )
[
} 1|| [ f >>temp ] when
] map ;
-: test-value-numbering ( insns -- insns )
- { } init-value-numbering
- value-numbering-step ;
-
+! Folding constants together
[
{
- T{ ##peek f V int-regs 45 D 1 }
- T{ ##copy f V int-regs 48 V int-regs 45 }
- T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
+ T{ ##load-reference f V int-regs 0 0.0 }
+ T{ ##load-reference f V int-regs 1 -0.0 }
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f V int-regs 1 D 1 }
}
] [
{
- T{ ##peek f V int-regs 45 D 1 }
- T{ ##copy f V int-regs 48 V int-regs 45 }
- T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
- } test-value-numbering
+ T{ ##load-reference f V int-regs 0 0.0 }
+ T{ ##load-reference f V int-regs 1 -0.0 }
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f V int-regs 1 D 1 }
+ } value-numbering-step
] unit-test
[
{
- T{ ##load-immediate f V int-regs 2 8 }
- T{ ##peek f V int-regs 3 D 0 }
- T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
- T{ ##replace f V int-regs 4 D 0 }
+ T{ ##load-reference f V int-regs 0 0.0 }
+ T{ ##load-reference f V int-regs 1 0.0 }
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f V int-regs 0 D 1 }
}
] [
{
- T{ ##load-immediate f V int-regs 2 8 }
- T{ ##peek f V int-regs 3 D 0 }
- T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 }
- T{ ##replace f V int-regs 4 D 0 }
- } test-value-numbering
+ T{ ##load-reference f V int-regs 0 0.0 }
+ T{ ##load-reference f V int-regs 1 0.0 }
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f V int-regs 1 D 1 }
+ } value-numbering-step
] unit-test
-[ t ] [
+[
{
- T{ ##peek f V int-regs 1 D 0 }
- T{ ##dispatch f V int-regs 1 V int-regs 2 }
- } dup test-value-numbering =
-] unit-test
-
-[ t ] [
+ T{ ##load-reference f V int-regs 0 t }
+ T{ ##load-reference f V int-regs 1 t }
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f V int-regs 0 D 1 }
+ }
+] [
{
- T{ ##peek f V int-regs 16 D 0 }
- T{ ##peek f V int-regs 17 D -1 }
- T{ ##sar-imm f V int-regs 18 V int-regs 17 3 }
- T{ ##add-imm f V int-regs 19 V int-regs 16 13 }
- T{ ##add f V int-regs 21 V int-regs 18 V int-regs 19 }
- T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 }
- T{ ##shl-imm f V int-regs 23 V int-regs 22 3 }
- T{ ##replace f V int-regs 23 D 0 }
- } dup test-value-numbering =
+ T{ ##load-reference f V int-regs 0 t }
+ T{ ##load-reference f V int-regs 1 t }
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f V int-regs 1 D 1 }
+ } value-numbering-step
] unit-test
+! Copy propagation
[
{
- T{ ##peek f V int-regs 1 D 0 }
- T{ ##shl-imm f V int-regs 2 V int-regs 1 3 }
- T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
- T{ ##replace f V int-regs 1 D 0 }
+ T{ ##peek f V int-regs 45 D 1 }
+ T{ ##copy f V int-regs 48 V int-regs 45 }
+ T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
}
] [
{
- T{ ##peek f V int-regs 1 D 0 }
- T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
- T{ ##shr-imm f V int-regs 3 V int-regs 2 3 }
- T{ ##replace f V int-regs 3 D 0 }
- } test-value-numbering
+ T{ ##peek f V int-regs 45 D 1 }
+ T{ ##copy f V int-regs 48 V int-regs 45 }
+ T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
+ } value-numbering-step
] unit-test
+! Compare propagation
[
{
T{ ##load-reference f V int-regs 1 + }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc/= }
T{ ##replace f V int-regs 6 D 0 }
- } test-value-numbering trim-temps
+ } value-numbering-step trim-temps
] unit-test
[
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare-imm f V int-regs 6 V int-regs 4 5 cc= }
T{ ##replace f V int-regs 6 D 0 }
- } test-value-numbering trim-temps
+ } value-numbering-step trim-temps
] unit-test
[
T{ ##compare-float f V int-regs 12 V double-float-regs 10 V double-float-regs 11 cc< }
T{ ##compare-imm f V int-regs 14 V int-regs 12 5 cc= }
T{ ##replace f V int-regs 14 D 0 }
- } test-value-numbering trim-temps
+ } value-numbering-step trim-temps
] unit-test
[
T{ ##peek f V int-regs 30 D -2 }
T{ ##compare f V int-regs 33 V int-regs 29 V int-regs 30 cc<= }
T{ ##compare-imm-branch f V int-regs 33 5 cc/= }
- } test-value-numbering trim-temps
+ } value-numbering-step trim-temps
] unit-test
+! Immediate operand conversion
[
{
- T{ ##copy f V int-regs 48 V int-regs 45 }
- T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
}
] [
- { V int-regs 45 } init-value-numbering
{
- T{ ##copy f V int-regs 48 V int-regs 45 }
- T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##add-imm f V int-regs 2 V int-regs 0 -100 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 0 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##sub f V int-regs 1 V int-regs 0 V int-regs 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##mul-imm f V int-regs 2 V int-regs 0 100 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##mul-imm f V int-regs 2 V int-regs 0 100 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##shl-imm f V int-regs 2 V int-regs 1 3 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 1 D 0 }
+ T{ ##mul-imm f V int-regs 2 V int-regs 1 8 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##and-imm f V int-regs 2 V int-regs 0 100 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##and-imm f V int-regs 2 V int-regs 0 100 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##or-imm f V int-regs 2 V int-regs 0 100 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##or-imm f V int-regs 2 V int-regs 0 100 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##xor-imm f V int-regs 2 V int-regs 0 100 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##xor-imm f V int-regs 2 V int-regs 0 100 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##compare-imm f V int-regs 2 V int-regs 0 100 cc<= }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##compare f V int-regs 2 V int-regs 0 V int-regs 1 cc<= }
+ } value-numbering-step trim-temps
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##compare-imm f V int-regs 2 V int-regs 0 100 cc>= }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##compare f V int-regs 2 V int-regs 1 V int-regs 0 cc<= }
+ } value-numbering-step trim-temps
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##compare-imm-branch f V int-regs 0 100 cc<= }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##compare-branch f V int-regs 0 V int-regs 1 cc<= }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##compare-imm-branch f V int-regs 0 100 cc>= }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##compare-branch f V int-regs 1 V int-regs 0 cc<= }
+ } value-numbering-step trim-temps
+] unit-test
+
+! Reassociation
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##add-imm f V int-regs 4 V int-regs 0 150 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##add f V int-regs 4 V int-regs 2 V int-regs 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##add-imm f V int-regs 4 V int-regs 0 150 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##add-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##add-imm f V int-regs 4 V int-regs 0 50 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##add-imm f V int-regs 2 V int-regs 0 -100 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##add-imm f V int-regs 4 V int-regs 0 -150 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##mul-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##mul-imm f V int-regs 4 V int-regs 0 5000 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##mul f V int-regs 4 V int-regs 2 V int-regs 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##mul-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##mul-imm f V int-regs 4 V int-regs 0 5000 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##mul f V int-regs 4 V int-regs 3 V int-regs 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##and-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##and-imm f V int-regs 4 V int-regs 0 32 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##and f V int-regs 4 V int-regs 2 V int-regs 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##and-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##and-imm f V int-regs 4 V int-regs 0 32 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##and f V int-regs 4 V int-regs 3 V int-regs 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##or-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##or-imm f V int-regs 4 V int-regs 0 118 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##or f V int-regs 4 V int-regs 2 V int-regs 3 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##or-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##or-imm f V int-regs 4 V int-regs 0 118 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##or f V int-regs 4 V int-regs 3 V int-regs 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##xor-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##xor-imm f V int-regs 4 V int-regs 0 86 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##xor f V int-regs 4 V int-regs 2 V int-regs 3 }
} value-numbering-step
] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##xor-imm f V int-regs 2 V int-regs 0 100 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##xor-imm f V int-regs 4 V int-regs 0 86 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 100 }
+ T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 }
+ T{ ##load-immediate f V int-regs 3 50 }
+ T{ ##xor f V int-regs 4 V int-regs 3 V int-regs 2 }
+ } value-numbering-step
+] unit-test
+
+! Simplification
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##load-immediate f V int-regs 2 0 }
+ T{ ##add-imm f V int-regs 3 V int-regs 0 0 }
+ T{ ##replace f V int-regs 0 D 0 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
+ T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+ T{ ##replace f V int-regs 3 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##load-immediate f V int-regs 2 0 }
+ T{ ##add-imm f V int-regs 3 V int-regs 0 0 }
+ T{ ##replace f V int-regs 0 D 0 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
+ T{ ##sub f V int-regs 3 V int-regs 0 V int-regs 2 }
+ T{ ##replace f V int-regs 3 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##load-immediate f V int-regs 2 0 }
+ T{ ##or-imm f V int-regs 3 V int-regs 0 0 }
+ T{ ##replace f V int-regs 0 D 0 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
+ T{ ##or f V int-regs 3 V int-regs 0 V int-regs 2 }
+ T{ ##replace f V int-regs 3 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##load-immediate f V int-regs 2 0 }
+ T{ ##xor-imm f V int-regs 3 V int-regs 0 0 }
+ T{ ##replace f V int-regs 0 D 0 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 }
+ T{ ##xor f V int-regs 3 V int-regs 0 V int-regs 2 }
+ T{ ##replace f V int-regs 3 D 0 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##shl-imm f V int-regs 2 V int-regs 0 0 }
+ T{ ##replace f V int-regs 0 D 0 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 }
+ T{ ##replace f V int-regs 2 D 0 }
+ } value-numbering-step
+] unit-test
+
+! Constant folding
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 3 }
+ T{ ##load-immediate f V int-regs 3 4 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 3 }
+ T{ ##add f V int-regs 3 V int-regs 1 V int-regs 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 3 }
+ T{ ##load-immediate f V int-regs 3 -2 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 3 }
+ T{ ##sub f V int-regs 3 V int-regs 1 V int-regs 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 2 }
+ T{ ##load-immediate f V int-regs 2 3 }
+ T{ ##load-immediate f V int-regs 3 6 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 2 }
+ T{ ##load-immediate f V int-regs 2 3 }
+ T{ ##mul f V int-regs 3 V int-regs 1 V int-regs 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 2 }
+ T{ ##load-immediate f V int-regs 2 1 }
+ T{ ##load-immediate f V int-regs 3 0 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 2 }
+ T{ ##load-immediate f V int-regs 2 1 }
+ T{ ##and f V int-regs 3 V int-regs 1 V int-regs 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 2 }
+ T{ ##load-immediate f V int-regs 2 1 }
+ T{ ##load-immediate f V int-regs 3 3 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 2 }
+ T{ ##load-immediate f V int-regs 2 1 }
+ T{ ##or f V int-regs 3 V int-regs 1 V int-regs 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 2 }
+ T{ ##load-immediate f V int-regs 2 3 }
+ T{ ##load-immediate f V int-regs 3 1 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 2 }
+ T{ ##load-immediate f V int-regs 2 3 }
+ T{ ##xor f V int-regs 3 V int-regs 1 V int-regs 2 }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 3 8 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##shl-imm f V int-regs 3 V int-regs 1 3 }
+ } value-numbering-step
+] unit-test
+
+cell 8 = [
+ [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 -1 }
+ T{ ##load-immediate f V int-regs 3 HEX: ffffffffffff }
+ }
+ ] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 -1 }
+ T{ ##shr-imm f V int-regs 3 V int-regs 1 16 }
+ } value-numbering-step
+ ] unit-test
+] when
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 -8 }
+ T{ ##load-immediate f V int-regs 3 -4 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 -8 }
+ T{ ##sar-imm f V int-regs 3 V int-regs 1 1 }
+ } value-numbering-step
+] unit-test
+
+cell 8 = [
+ [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 65536 }
+ T{ ##load-immediate f V int-regs 2 140737488355328 }
+ T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+ }
+ ] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 65536 }
+ T{ ##shl-imm f V int-regs 2 V int-regs 1 31 }
+ T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+ } value-numbering-step
+ ] unit-test
+
+ [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 2 140737488355328 }
+ T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+ }
+ ] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 2 140737488355328 }
+ T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+ } value-numbering-step
+ ] unit-test
+
+ [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 2 2147483647 }
+ T{ ##add-imm f V int-regs 3 V int-regs 0 2147483647 }
+ T{ ##add-imm f V int-regs 4 V int-regs 3 2147483647 }
+ }
+ ] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 2 2147483647 }
+ T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 }
+ T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 }
+ } value-numbering-step
+ ] unit-test
+] when
+
+! Branch folding
+[
+ {
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##load-immediate f V int-regs 3 5 }
+ }
+] [
+ {
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc= }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##load-reference f V int-regs 3 t }
+ }
+] [
+ {
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc/= }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##load-reference f V int-regs 3 t }
+ }
+] [
+ {
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc< }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##load-immediate f V int-regs 3 5 }
+ }
+] [
+ {
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##compare f V int-regs 3 V int-regs 2 V int-regs 1 cc< }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 5 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc< }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-reference f V int-regs 1 t }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 5 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc> }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-reference f V int-regs 1 t }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc>= }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-immediate f V int-regs 1 5 }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc/= }
+ } value-numbering-step
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-reference f V int-regs 1 t }
+ }
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc= }
+ } value-numbering-step
+] unit-test
+
+: test-branch-folding ( insns -- insns' n )
+ <basic-block>
+ [ V{ 0 1 } clone >>successors basic-block set value-numbering-step ] keep
+ successors>> first ;
+
+[
+ {
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##branch }
+ }
+ 1
+] [
+ {
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##compare-branch f V int-regs 1 V int-regs 2 cc= }
+ } test-branch-folding
+] unit-test
+
+[
+ {
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##branch }
+ }
+ 0
+] [
+ {
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##compare-branch f V int-regs 1 V int-regs 2 cc/= }
+ } test-branch-folding
+] unit-test
+
+[
+ {
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##branch }
+ }
+ 0
+] [
+ {
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##compare-branch f V int-regs 1 V int-regs 2 cc< }
+ } test-branch-folding
+] unit-test
+
+[
+ {
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##branch }
+ }
+ 1
+] [
+ {
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##compare-branch f V int-regs 2 V int-regs 1 cc< }
+ } test-branch-folding
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+ }
+ 1
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
+ } test-branch-folding
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+ }
+ 0
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-branch f V int-regs 0 V int-regs 0 cc<= }
+ } test-branch-folding
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+ }
+ 1
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-branch f V int-regs 0 V int-regs 0 cc> }
+ } test-branch-folding
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+ }
+ 0
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-branch f V int-regs 0 V int-regs 0 cc>= }
+ } test-branch-folding
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+ }
+ 0
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-branch f V int-regs 0 V int-regs 0 cc= }
+ } test-branch-folding
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+ }
+ 1
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-branch f V int-regs 0 V int-regs 0 cc/= }
+ } test-branch-folding
+] unit-test
+
+[
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##load-reference f V int-regs 1 t }
+ T{ ##branch }
+ }
+ 0
+] [
+ {
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= }
+ T{ ##compare-imm-branch f V int-regs 1 5 cc/= }
+ } test-branch-folding
+] unit-test
+
+! More branch folding tests
+V{ T{ ##branch } } 0 test-bb
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
+} 1 test-bb
+
+V{
+ T{ ##load-immediate f V int-regs 1 1 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##load-immediate f V int-regs 2 2 }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##phi f V int-regs 3 { } }
+ T{ ##replace f V int-regs 3 D 0 }
+ T{ ##return }
+} 4 test-bb
+
+4 get instructions>> first
+2 get V int-regs 1 2array
+3 get V int-regs 2 2array 2array
+>>inputs drop
+
+test-diamond
+
+[ ] [
+ cfg new 0 get >>entry
+ value-numbering
+ compute-predecessors
+ eliminate-phis drop
+] unit-test
+
+[ 1 ] [ 1 get successors>> length ] unit-test
+
+[ t ] [ 1 get successors>> first 3 get eq? ] unit-test
+
+[ 3 ] [ 4 get instructions>> length ] unit-test
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+} 0 test-bb
+
+V{
+ T{ ##peek f V int-regs 1 D 1 }
+ T{ ##compare-branch f V int-regs 1 V int-regs 1 cc< }
+} 1 test-bb
+
+V{
+ T{ ##copy f V int-regs 2 V int-regs 0 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##phi f V int-regs 3 V{ } }
+ T{ ##branch }
+} 3 test-bb
+
+V{
+ T{ ##replace f V int-regs 3 D 0 }
+ T{ ##return }
+} 4 test-bb
+
+1 get V int-regs 1 2array
+2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs)
+
+test-diamond
+
+[ ] [
+ cfg new 0 get >>entry
+ compute-predecessors
+ value-numbering
+ compute-predecessors
+ eliminate-dead-code
+ drop
+] unit-test
+
+[ t ] [ 1 get successors>> first 3 get eq? ] unit-test
+
+[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test
+
+V{ T{ ##prologue } T{ ##branch } } 0 test-bb
+
+V{
+ T{ ##peek { dst V int-regs 15 } { loc D 0 } }
+ T{ ##copy { dst V int-regs 16 } { src V int-regs 15 } }
+ T{ ##copy { dst V int-regs 17 } { src V int-regs 15 } }
+ T{ ##copy { dst V int-regs 18 } { src V int-regs 15 } }
+ T{ ##copy { dst V int-regs 19 } { src V int-regs 15 } }
+ T{ ##compare
+ { dst V int-regs 20 }
+ { src1 V int-regs 18 }
+ { src2 V int-regs 19 }
+ { cc cc= }
+ { temp V int-regs 22 }
+ }
+ T{ ##copy { dst V int-regs 21 } { src V int-regs 20 } }
+ T{ ##compare-imm-branch
+ { src1 V int-regs 21 }
+ { src2 5 }
+ { cc cc/= }
+ }
+} 1 test-bb
+
+V{
+ T{ ##copy { dst V int-regs 23 } { src V int-regs 15 } }
+ T{ ##copy { dst V int-regs 24 } { src V int-regs 15 } }
+ T{ ##load-reference { dst V int-regs 25 } { obj t } }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##replace { src V int-regs 25 } { loc D 0 } }
+ T{ ##epilogue }
+ T{ ##return }
+} 3 test-bb
+
+V{
+ T{ ##copy { dst V int-regs 26 } { src V int-regs 15 } }
+ T{ ##copy { dst V int-regs 27 } { src V int-regs 15 } }
+ T{ ##add
+ { dst V int-regs 28 }
+ { src1 V int-regs 26 }
+ { src2 V int-regs 27 }
+ }
+ T{ ##branch }
+} 4 test-bb
+
+V{
+ T{ ##replace { src V int-regs 28 } { loc D 0 } }
+ T{ ##epilogue }
+ T{ ##return }
+} 5 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 4 get V{ } 2sequence >>successors drop
+2 get 3 get 1vector >>successors drop
+4 get 5 get 1vector >>successors drop
+
+[ ] [
+ cfg new 0 get >>entry
+ value-numbering eliminate-dead-code drop
+] unit-test
+
+[ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs biassocs classes kernel math accessors
-sorting sets sequences
-compiler.cfg.local
-compiler.cfg.liveness
+sorting sets sequences fry
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.renaming
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions
-compiler.cfg.value-numbering.propagate
compiler.cfg.value-numbering.simplify
compiler.cfg.value-numbering.rewrite ;
IN: compiler.cfg.value-numbering
-: number-input-values ( live-in -- )
- [ [ f next-input-expr simplify ] dip set-vn ] each ;
+! Local value numbering. Predecessors must be recomputed after this
+: vreg>vreg-mapping ( -- assoc )
+ vregs>vns get [ keys ] keep
+ '[ dup _ [ at ] [ value-at ] bi ] H{ } map>assoc ;
-: init-value-numbering ( live-in -- )
- init-value-graph
- init-expressions
- number-input-values ;
+: rename-uses ( insns -- )
+ vreg>vreg-mapping renamings [
+ [ rename-insn-uses ] each
+ ] with-variable ;
: value-numbering-step ( insns -- insns' )
- [ [ number-values ] [ rewrite propagate ] bi ] map ;
+ init-value-graph
+ init-expressions
+ [ rewrite ] map
+ dup rename-uses ;
: value-numbering ( cfg -- cfg' )
- [ init-value-numbering ] [ value-numbering-step ] local-optimization ;
+ [ value-numbering-step ] local-optimization cfg-changed ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets sequences locals
compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop
-compiler.cfg.liveness compiler.cfg.local ;
+compiler.cfg.rpo ;
IN: compiler.cfg.write-barrier
! Eliminate redundant write barrier hits.
[ eliminate-write-barrier ] map sift ;
: eliminate-write-barriers ( cfg -- cfg' )
- [ drop ] [ write-barriers-step ] local-optimization ;
+ [ write-barriers-step ] local-optimization ;
: lookup-label ( id -- label )
labels get [ drop <label> ] cache ;
+M: ##no-tco generate-insn drop ;
+
M: ##load-immediate generate-insn
[ dst>> register ] [ val>> ] bi %load-immediate ;
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: ##not generate-insn dst/src %not ;
M: ##log2 generate-insn dst/src %log2 ;
-: src1/src2 ( insn -- src1 src2 )
- [ src1>> register ] [ src2>> register ] bi ; inline
-
-: src1/src2/temp1/temp2 ( insn -- src1 src2 temp1 temp2 )
- [ src1/src2 ] [ temp1>> register ] [ temp2>> register ] tri ; inline
+: label/dst/src1/src2 ( insn -- label dst src1 src2 )
+ [ label>> lookup-label ] [ dst/src1/src2 ] bi ; inline
-M: ##fixnum-add generate-insn src1/src2 %fixnum-add ;
-M: ##fixnum-add-tail generate-insn src1/src2 %fixnum-add-tail ;
-M: ##fixnum-sub generate-insn src1/src2 %fixnum-sub ;
-M: ##fixnum-sub-tail generate-insn src1/src2 %fixnum-sub-tail ;
-M: ##fixnum-mul generate-insn src1/src2/temp1/temp2 %fixnum-mul ;
-M: ##fixnum-mul-tail generate-insn src1/src2/temp1/temp2 %fixnum-mul-tail ;
+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>> register ] bi ; inline
}
] [
[ { 1 2 3 } "x" "y" linear-scan-regression ] { } make
-] unit-test
\ No newline at end of file
+] unit-test
+
+! Regression from Doug's value numbering changes
+[ t ] [ 2 [ 1 swap fixnum< ] compile-call ] unit-test
+[ 3 ] [ 2 [ 1 swap fixnum< [ 3 ] [ 4 ] if ] compile-call ] unit-test
+
+cell 4 = [
+ [ 0 ] [ 101 [ dup fixnum-fast 1 fixnum+fast 20 fixnum-shift-fast 20 fixnum-shift-fast ] compile-call ] unit-test
+] when
+
+! Regression from Slava's value numbering changes
+[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test
\ No newline at end of file
[ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] unit-test
[ -1 ] [ -123 -64 [ fixnum-shift ] compile-call ] unit-test
-[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test
-[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
-[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
+[ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-call ] unit-test
+[ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-call ] unit-test
+[ 4294967296 ] [ 1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
+[ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-call ] unit-test
+[ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-call ] unit-test
+[ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
-[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test
-[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
+[ 8 ] [ 1 3 [ fixnum-shift-fast ] compile-call ] unit-test
+[ 8 ] [ 1 3 [ 15 bitand fixnum-shift-fast ] compile-call ] unit-test
+[ 8 ] [ 1 [ 3 fixnum-shift-fast ] compile-call ] unit-test
+[ 8 ] [ [ 1 3 fixnum-shift-fast ] compile-call ] unit-test
+[ -8 ] [ -1 3 [ fixnum-shift-fast ] compile-call ] unit-test
+[ -8 ] [ -1 3 [ 15 bitand fixnum-shift-fast ] compile-call ] unit-test
+[ -8 ] [ -1 [ 3 fixnum-shift-fast ] compile-call ] unit-test
+[ -8 ] [ [ -1 3 fixnum-shift-fast ] compile-call ] unit-test
+
+[ 2 ] [ 8 -2 [ fixnum-shift-fast ] compile-call ] unit-test
+[ 2 ] [ 8 2 [ 15 bitand neg fixnum-shift-fast ] compile-call ] unit-test
+[ 2 ] [ 8 [ -2 fixnum-shift-fast ] compile-call ] unit-test
[ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-call ] unit-test
[ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-call ] unit-test
[ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-call ] unit-test
[ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test
+[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test
+[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test
+[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test
+
+[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test
+[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test
+
[ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test
[ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test
[ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test
[ t ] [ f [ f eq? ] compile-call ] unit-test
+cell 8 = [
+ [ HEX: 40400000 ] [
+ HEX: 4200 [ HEX: 7fff fixnum-bitand 13 fixnum-shift-fast 112 23 fixnum-shift-fast fixnum+fast ]
+ compile-call
+ ] unit-test
+] when
+
! regression
[ 3 ] [
100001 f <array> 3 100000 pick set-nth
math.order math.functions accessors hashtables classes assocs
io.encodings.utf8 io.encodings.ascii io.encodings fry slots
sorting.private combinators.short-circuit grouping prettyprint
+generalizations
compiler.tree
compiler.tree.combinators
compiler.tree.cleanup
{ fixnum-shift-fast } inlined?
] unit-test
+[ t ] [
+ [ 1 swap 7 bitand shift ]
+ { shift fixnum-shift } inlined?
+] unit-test
+
cell-bits 32 = [
[ t ] [
[ { fixnum fixnum } declare 1 swap 31 bitand shift ]
[ { integer integer } declare + drop ]
{ + +-integer-integer } inlined?
] unit-test
+
+[ [ ] ] [
+ [
+ 20 f <array>
+ [ 0 swap nth ] keep
+ [ 1 swap nth ] keep
+ [ 2 swap nth ] keep
+ [ 3 swap nth ] keep
+ [ 4 swap nth ] keep
+ [ 5 swap nth ] keep
+ [ 6 swap nth ] keep
+ [ 7 swap nth ] keep
+ [ 8 swap nth ] keep
+ [ 9 swap nth ] keep
+ [ 10 swap nth ] keep
+ [ 11 swap nth ] keep
+ [ 12 swap nth ] keep
+ 14 ndrop
+ ] cleaned-up-tree nodes>quot
+] unit-test
\ No newline at end of file
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors words assocs sequences arrays namespaces
-fry locals definitions classes.algebra
+fry locals definitions classes classes.algebra generic
stack-checker.state
stack-checker.backend
compiler.tree
compiler.tree.dead-code.liveness ;
IN: compiler.tree.dead-code.simple
-: flushable? ( word -- ? )
- [ "flushable" word-prop ] [ "predicating" word-prop ] bi or ;
+GENERIC: flushable? ( word -- ? )
+
+M: predicate flushable? drop t ;
+
+M: word flushable? "flushable" word-prop ;
+
+M: method-body flushable? "method-generic" word-prop flushable? ;
: flushable-call? ( #call -- ? )
dup word>> dup flushable? [
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
compiler.tree.builder
compiler.tree.optimizer
compiler.tree.combinators
-compiler.tree.checker ;
+compiler.tree.checker
+compiler.tree.dead-code
+compiler.tree.modular-arithmetic ;
FROM: fry => _ ;
RENAME: _ match => __
IN: compiler.tree.debugger
: cleaned-up-tree ( quot -- nodes )
[
- check-optimizer? on
- build-tree optimize-tree
+ build-tree
+ analyze-recursive
+ normalize
+ propagate
+ cleanup
+ compute-def-use
+ remove-dead-code
+ compute-def-use
+ optimize-modular-arithmetic
] with-scope ;
: inlined? ( quot seq/word -- ? )
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences words memoize combinators
classes classes.builtin classes.tuple math.partial-dispatch
-fry assocs
+fry assocs combinators.short-circuit
compiler.tree
compiler.tree.combinators
compiler.tree.propagation.info
M: #copy finalize* drop f ;
M: #shuffle finalize*
- dup
- [ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
- [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ]
- bi and [ drop f ] when ;
+ dup {
+ [ [ in-d>> length ] [ out-d>> length ] bi = ]
+ [ [ in-r>> length ] [ out-r>> length ] bi = ]
+ [ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at = ] 2all? ]
+ [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at = ] 2all? ]
+ } 1&& [ drop f ] when ;
MEMO: cached-expansion ( word -- nodes )
def>> splice-final ;
[ drop ]
} cond ;
+M: math-partial finalize-word
+ dup primitive? [ drop ] [ nip cached-expansion ] if ;
+
M: word finalize-word drop ;
M: #call finalize*
--- /dev/null
+Slava Pestov
+Daniel Ehrenberg
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.modular-arithmetic.tests
USING: kernel kernel.private tools.test math math.partial-dispatch
math.private accessors slots.private sequences strings sbufs
compiler.tree.builder
-compiler.tree.optimizer
-compiler.tree.debugger ;
+compiler.tree.normalization
+compiler.tree.debugger
+alien.accessors layouts combinators byte-arrays ;
: test-modular-arithmetic ( quot -- quot' )
- build-tree optimize-tree nodes>quot ;
+ cleaned-up-tree nodes>quot ;
[ [ >R >fixnum R> >fixnum fixnum+fast ] ]
[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test
] unit-test
[ [ >fixnum 255 fixnum-bitand ] ]
-[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
\ No newline at end of file
+[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
+
+[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-1 ] ]
+[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-1 ] test-modular-arithmetic ] unit-test
+
+[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-2 ] ]
+[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-2 ] test-modular-arithmetic ] unit-test
+
+cell {
+ { 4 [ [ [ "COMPLEX SHUFFLE" fixnum+ "COMPLEX SHUFFLE" set-alien-unsigned-4 ] ] ] }
+ { 8 [ [ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-4 ] ] ] }
+} case
+[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-4 ] test-modular-arithmetic ] unit-test
+
+[ [ "COMPLEX SHUFFLE" fixnum+ "COMPLEX SHUFFLE" set-alien-unsigned-8 ] ]
+[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-8 ] test-modular-arithmetic ] unit-test
+
+[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-signed-1 ] ]
+[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-1 ] test-modular-arithmetic ] unit-test
+
+[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-signed-2 ] ]
+[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-2 ] test-modular-arithmetic ] unit-test
+
+cell {
+ { 4 [ [ [ "COMPLEX SHUFFLE" fixnum+ "COMPLEX SHUFFLE" set-alien-signed-4 ] ] ] }
+ { 8 [ [ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-signed-4 ] ] ] }
+} case
+[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-4 ] test-modular-arithmetic ] unit-test
+
+[ [ "COMPLEX SHUFFLE" fixnum+ "COMPLEX SHUFFLE" set-alien-signed-8 ] ]
+[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-8 ] test-modular-arithmetic ] unit-test
+
+[ t ] [ [ { fixnum byte-array } declare [ + ] with map ] { + fixnum+ >fixnum } inlined? ] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.partial-dispatch namespaces sequences sets
accessors assocs words kernel memoize fry combinators
-combinators.short-circuit
+combinators.short-circuit layouts alien.accessors
compiler.tree
compiler.tree.combinators
compiler.tree.def-use
{ bitand bitor bitxor bitnot }
[ t "modular-arithmetic" set-word-prop ] each
+{
+ >fixnum
+ set-alien-unsigned-1 set-alien-signed-1
+ set-alien-unsigned-2 set-alien-signed-2
+}
+cell 8 = [
+ { set-alien-unsigned-4 set-alien-signed-4 } append
+] when
+[ t "low-order" set-word-prop ] each
+
SYMBOL: modularize-values
: modular-value? ( value -- ? )
GENERIC: compute-modularized-values* ( node -- )
M: #call compute-modularized-values*
- dup word>> \ >fixnum eq?
+ dup word>> "low-order" word-prop
[ in-d>> first maybe-modularize ] [ drop ] if ;
M: node compute-modularized-values* drop ;
: ?check ( nodes -- nodes' )
check-optimizer? get [
- compute-def-use
dup check-nodes
] when ;
--- /dev/null
+Slava Pestov
+Daniel Ehrenberg
--- /dev/null
+! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.tree.propagation.call-effect tools.test fry math effects kernel
+compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences ;
+IN: compiler.tree.propagation.call-effect.tests
+
+[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
+[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
+[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
+[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
+
+[ t ] [ [ + ] cached-effect (( a b -- c )) effect= ] unit-test
+[ t ] [ 5 [ + ] curry cached-effect (( a -- c )) effect= ] unit-test
+[ t ] [ 5 [ ] curry cached-effect (( -- c )) effect= ] unit-test
+[ t ] [ [ dup ] [ drop ] compose cached-effect (( a -- b )) effect= ] unit-test
+[ t ] [ [ drop ] [ dup ] compose cached-effect (( a b -- c d )) effect= ] unit-test
+[ t ] [ [ 2drop ] [ dup ] compose cached-effect (( a b c -- d e )) effect= ] unit-test
+[ t ] [ [ 1 2 3 ] [ 2drop ] compose cached-effect (( -- a )) effect= ] unit-test
+[ t ] [ [ 1 2 ] [ 3drop ] compose cached-effect (( a -- )) effect= ] unit-test
+
+: optimized-quot ( quot -- quot' )
+ build-tree optimize-tree nodes>quot ;
+
+: compiled-call2 ( a quot: ( a -- b ) -- b )
+ call( a -- b ) ;
+
+: compiled-execute2 ( a b word: ( a b -- c ) -- c )
+ execute( a b -- c ) ;
+
+[ [ 3 ] ] [ [ 1 2 \ + execute( a b -- c ) ] optimized-quot ] unit-test
+[ [ 3 ] ] [ [ 1 2 [ + ] call( a b -- c ) ] optimized-quot ] unit-test
+[ [ 3 ] ] [ [ 1 2 '[ _ + ] call( a -- b ) ] optimized-quot ] unit-test
+[ [ 3 ] ] [ [ 1 2 '[ _ ] [ + ] compose call( a -- b ) ] optimized-quot ] unit-test
+
+[ 1 2 { [ + ] } first compiled-call2 ] must-fail
+[ 3 ] [ 1 2 { + } first compiled-execute2 ] unit-test
+[ 3 ] [ 1 2 '[ _ + ] compiled-call2 ] unit-test
+[ 3 ] [ 1 2 '[ _ ] [ + ] compose compiled-call2 ] unit-test
+[ 3 ] [ 1 2 \ + compiled-execute2 ] unit-test
+
+[ 3 ] [ 1 2 { [ + ] } first call( a b -- c ) ] unit-test
+[ 3 ] [ 1 2 { + } first execute( a b -- c ) ] unit-test
+[ 3 ] [ 1 2 '[ _ + ] call( a -- b ) ] unit-test
+[ 3 ] [ 1 2 '[ _ ] [ + ] compose call( a -- b ) ] unit-test
+
+[ t ] [ [ 2 '[ _ ] [ + ] compose ] final-info first infer-value (( object -- object )) effect= ] unit-test
+[ t ] [ [ 2 '[ _ ] 1 '[ _ + ] compose ] final-info first infer-value (( -- object )) effect= ] unit-test
+[ t ] [ [ 2 '[ _ + ] ] final-info first infer-value (( object -- object )) effect= ] unit-test
+[ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test
+[ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test
+[ f ] [ [ dup drop ] final-info first infer-value ] unit-test
--- /dev/null
+! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators combinators.private effects fry
+kernel kernel.private make sequences continuations quotations
+words math stack-checker stack-checker.transforms
+compiler.tree.propagation.info slots.private ;
+IN: compiler.tree.propagation.call-effect
+
+! call( and execute( have complex expansions.
+
+! call( uses the following strategy:
+! - Inline caching. If the quotation is the same as last time, just call it unsafely
+! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot,
+! and compare it with declaration. If matches, call it unsafely.
+! - Fallback. If the above doesn't work, call it and compare the datastack before
+! and after to make sure it didn't mess anything up.
+
+! execute( uses a similar strategy.
+
+TUPLE: inline-cache value ;
+
+: cache-hit? ( word/quot ic -- ? )
+ [ value>> eq? ] [ value>> ] bi and ; inline
+
+SINGLETON: +unknown+
+
+GENERIC: cached-effect ( quot -- effect )
+
+M: object cached-effect drop +unknown+ ;
+
+GENERIC: curry-effect ( effect -- effect' )
+
+M: +unknown+ curry-effect ;
+
+M: effect curry-effect
+ [ in>> length ] [ out>> length ] [ terminated?>> ] tri
+ pick 0 = [ [ 1+ ] dip ] [ [ 1- ] 2dip ] if
+ effect boa ;
+
+M: curry cached-effect
+ quot>> cached-effect curry-effect ;
+
+: compose-effects* ( effect1 effect2 -- effect' )
+ {
+ { [ 2dup [ effect? ] both? ] [ compose-effects ] }
+ { [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] }
+ } cond ;
+
+M: compose cached-effect
+ [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
+
+M: quotation cached-effect
+ dup cached-effect>>
+ [ ] [
+ [ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
+ (>>cached-effect)
+ ] ?if ;
+
+: call-effect-unsafe? ( quot effect -- ? )
+ [ cached-effect ] dip
+ over +unknown+ eq?
+ [ 2drop f ] [ effect<= ] if ; inline
+
+: (call-effect-slow>quot) ( in out effect -- quot )
+ [
+ [ [ datastack ] dip dip ] %
+ [ [ , ] bi@ \ check-datastack , ] dip
+ '[ _ wrong-values ] , \ unless ,
+ ] [ ] make ;
+
+: call-effect-slow>quot ( effect -- quot )
+ [ in>> length ] [ out>> length ] [ ] tri
+ [ (call-effect-slow>quot) ] keep add-effect-input
+ [ call-effect-unsafe ] 2curry ;
+
+: call-effect-slow ( quot effect -- ) drop call ;
+
+\ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
+
+\ call-effect-slow t "no-compile" set-word-prop
+
+: call-effect-fast ( quot effect inline-cache -- )
+ 2over call-effect-unsafe?
+ [ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ]
+ [ drop call-effect-slow ]
+ if ; inline
+
+: call-effect-ic ( quot effect inline-cache -- )
+ 3dup nip cache-hit?
+ [ drop call-effect-unsafe ]
+ [ call-effect-fast ]
+ if ; inline
+
+: call-effect>quot ( effect -- quot )
+ inline-cache new '[ drop _ _ call-effect-ic ] ;
+
+: execute-effect-slow ( word effect -- )
+ [ '[ _ execute ] ] dip call-effect-slow ; inline
+
+: execute-effect-unsafe? ( word effect -- ? )
+ over optimized? [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
+
+: execute-effect-fast ( word effect inline-cache -- )
+ 2over execute-effect-unsafe?
+ [ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ]
+ [ drop execute-effect-slow ]
+ if ; inline
+
+: execute-effect-ic ( word effect inline-cache -- )
+ 3dup nip cache-hit?
+ [ drop execute-effect-unsafe ]
+ [ execute-effect-fast ]
+ if ; inline
+
+: execute-effect>quot ( effect -- quot )
+ inline-cache new '[ drop _ _ execute-effect-ic ] ;
+
+: last2 ( seq -- penultimate ultimate )
+ 2 tail* first2 ;
+
+: top-two ( #call -- effect value )
+ in-d>> last2 [ value-info ] bi@
+ literal>> swap ;
+
+ERROR: uninferable ;
+
+: remove-effect-input ( effect -- effect' )
+ (( -- object )) swap compose-effects ;
+
+: (infer-value) ( value-info -- effect )
+ dup class>> {
+ { \ quotation [
+ literal>> [ uninferable ] unless* cached-effect
+ dup +unknown+ = [ uninferable ] when
+ ] }
+ { \ curry [
+ slots>> third (infer-value)
+ remove-effect-input
+ ] }
+ { \ compose [
+ slots>> last2 [ (infer-value) ] bi@
+ compose-effects
+ ] }
+ [ uninferable ]
+ } case ;
+
+: infer-value ( value-info -- effect/f )
+ [ (infer-value) ]
+ [ dup uninferable? [ 2drop f ] [ rethrow ] if ]
+ recover ;
+
+: (value>quot) ( value-info -- quot )
+ dup class>> {
+ { \ quotation [ literal>> '[ drop @ ] ] }
+ { \ curry [
+ slots>> third (value>quot)
+ '[ [ obj>> ] [ quot>> @ ] bi ]
+ ] }
+ { \ compose [
+ slots>> last2 [ (value>quot) ] bi@
+ '[ [ first>> @ ] [ second>> @ ] bi ]
+ ] }
+ } case ;
+
+: value>quot ( value-info -- quot: ( code effect -- ) )
+ (value>quot) '[ drop @ ] ;
+
+: call-inlining ( #call -- quot/f )
+ top-two dup infer-value [
+ pick effect<=
+ [ nip value>quot ]
+ [ drop call-effect>quot ] if
+ ] [ drop call-effect>quot ] if* ;
+
+\ call-effect [ call-inlining ] "custom-inlining" set-word-prop
+
+: execute-inlining ( #call -- quot/f )
+ top-two >literal< [
+ 2dup swap execute-effect-unsafe?
+ [ nip '[ 2drop _ execute ] ]
+ [ drop execute-effect>quot ] if
+ ] [ drop execute-effect>quot ] if ;
+
+\ execute-effect [ execute-inlining ] "custom-inlining" set-word-prop
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra classes.tuple
classes.tuple.private kernel accessors math math.intervals
-namespaces sequences words combinators
+namespaces sequences words combinators byte-arrays strings
arrays compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
[ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
f prefix ;
+UNION: fixed-length array byte-array string ;
+
: init-literal-info ( info -- info )
+ [-inf,inf] >>interval
dup literal>> class >>class
- dup literal>> dup real? [ [a,a] >>interval ] [
- [ [-inf,inf] >>interval ] dip
- dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if
- ] if ; inline
+ dup literal>> {
+ { [ dup real? ] [ [a,a] >>interval ] }
+ { [ dup tuple? ] [ tuple-slot-infos >>slots ] }
+ { [ dup fixed-length? ] [ length <literal-info> >>length ] }
+ [ drop ]
+ } cond ; inline
: init-value-info ( info -- info )
dup literal?>> [
arrays assocs classes classes.algebra combinators generic.math
splitting fry locals classes.tuple alien.accessors
classes.tuple.private slots.private definitions strings.private
-vectors hashtables generic
+vectors hashtables generic quotations
stack-checker.state
compiler.tree.comparisons
compiler.tree.propagation.info
compiler.tree.propagation.nodes
compiler.tree.propagation.slots
compiler.tree.propagation.simple
-compiler.tree.propagation.constraints ;
+compiler.tree.propagation.constraints
+compiler.tree.propagation.call-effect
+compiler.tree.propagation.transforms ;
IN: compiler.tree.propagation.known-words
\ fixnum
] "outputs" set-word-prop
] assoc-each
-: rem-custom-inlining ( #call -- quot/f )
- second value-info literal>> dup integer?
- [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
-
-{
- mod-integer-integer
- mod-integer-fixnum
- mod-fixnum-integer
- fixnum-mod
-} [
- [
- in-d>> dup first value-info interval>> [0,inf] interval-subset?
- [ rem-custom-inlining ] [ drop f ] if
- ] "custom-inlining" set-word-prop
-] each
-
-\ rem [
- in-d>> rem-custom-inlining
-] "custom-inlining" set-word-prop
-
-{
- bitand-integer-integer
- bitand-integer-fixnum
- bitand-fixnum-integer
-} [
- [
- in-d>> second value-info >literal< [
- 0 most-positive-fixnum between?
- [ [ >fixnum ] bi@ fixnum-bitand ] f ?
- ] when
- ] "custom-inlining" set-word-prop
-] each
-
{ numerator denominator }
[ [ drop integer <class-info> ] "outputs" set-word-prop ] each
"outputs" set-word-prop
] each
-! Generate more efficient code for common idiom
-\ clone [
- in-d>> first value-info literal>> {
- { V{ } [ [ drop { } 0 vector boa ] ] }
- { H{ } [ [ drop 0 <hashtable> ] ] }
- [ drop f ]
- } case
-] "custom-inlining" set-word-prop
-
\ slot [
dup literal?>>
[ literal>> swap value-info-slot ] [ 2drop object-info ] if
bi
] [ 2drop object-info ] if
] "outputs" set-word-prop
-
-\ instance? [
- in-d>> second value-info literal>> dup class?
- [ "predicate" word-prop '[ drop @ ] ] [ drop f ] if
-] "custom-inlining" set-word-prop
-
-\ equal? [
- ! If first input has a known type and second input is an
- ! object, we convert this to [ swap equal? ].
- in-d>> first2 value-info class>> object class= [
- value-info class>> \ equal? specific-method
- [ swap equal? ] f ?
- ] [ drop f ] if
-] "custom-inlining" set-word-prop
compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals
specialized-arrays.double system sorting math.libm
-math.intervals quotations ;
+math.intervals quotations effects ;
IN: compiler.tree.propagation.tests
[ V{ } ] [ [ ] final-classes ] unit-test
[ float ] [ [ { float float } declare mod ] final-math-class ] unit-test
-[ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
+[ V{ fixnum } ] [ [ 255 bitand ] final-classes ] unit-test
-[ V{ integer } ] [
+[ V{ fixnum } ] [
[ [ 255 bitand ] [ 65535 bitand ] bi + ] final-classes
] unit-test
[ { fixnum } declare dup 10 eq? [ "A" throw ] unless ] final-literals
] unit-test
+[ V{ 3 } ] [ [ [ { 1 2 3 } ] [ { 4 5 6 } ] if length ] final-literals ] unit-test
+
+[ V{ 3 } ] [ [ [ B{ 1 2 3 } ] [ B{ 4 5 6 } ] if length ] final-literals ] unit-test
+
+[ V{ 3 } ] [ [ [ "yay" ] [ "hah" ] if length ] final-literals ] unit-test
+
+[ V{ 3 } ] [ [ 3 <byte-array> length ] final-literals ] unit-test
+
+[ V{ 3 } ] [ [ 3 f <string> length ] final-literals ] unit-test
+
! Slot propagation
TUPLE: prop-test-tuple { x integer } ;
[ { bignum integer } declare [ shift ] keep ] final-classes
] unit-test
+[ V{ fixnum } ] [ [ >fixnum 15 bitand 1 swap shift ] final-classes ] unit-test
+
+[ V{ fixnum } ] [ [ 15 bitand 1 swap shift ] final-classes ] unit-test
+
[ V{ fixnum } ] [
[ { fixnum } declare log2 ] final-classes
] unit-test
! Joe found an oversight
[ V{ integer } ] [ [ >integer ] final-classes ] unit-test
+
+TUPLE: foo bar ;
+
+[ t ] [ [ foo new ] { new } inlined? ] unit-test
+
+GENERIC: whatever ( x -- y )
+M: number whatever drop foo ;
+
+[ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test
+
+: that-thing ( -- class ) foo ;
+
+[ f ] [ [ that-thing new ] { new } inlined? ] unit-test
+
+GENERIC: whatever2 ( x -- y )
+M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ;
+M: f whatever2 ;
+
+[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
+[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test
+
+[ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test
+[ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test
+
+[ t ] [ [ { 1 2 3 } memq? ] { memq? } inlined? ] unit-test
+[ f ] [ [ { 1 2 3 } swap memq? ] { memq? } inlined? ] unit-test
+
+[ t ] [ [ V{ } clone ] { clone (clone) } inlined? ] unit-test
+[ f ] [ [ { } clone ] { clone (clone) } inlined? ] unit-test
+
+[ f ] [ [ instance? ] { instance? } inlined? ] unit-test
+[ f ] [ [ 5 instance? ] { instance? } inlined? ] unit-test
+[ t ] [ [ array instance? ] { instance? } inlined? ] unit-test
+
+[ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test
+[ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test
--- /dev/null
+Slava Pestov
+Daniel Ehrenberg
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences words fry generic accessors classes.tuple
+classes classes.algebra definitions stack-checker.state quotations
+classes.tuple.private math math.partial-dispatch math.private
+math.intervals layouts math.order vectors hashtables
+combinators effects generalizations assocs sets
+combinators.short-circuit sequences.private locals
+stack-checker namespaces compiler.tree.propagation.info ;
+IN: compiler.tree.propagation.transforms
+
+\ equal? [
+ ! If first input has a known type and second input is an
+ ! object, we convert this to [ swap equal? ].
+ in-d>> first2 value-info class>> object class= [
+ value-info class>> \ equal? specific-method
+ [ swap equal? ] f ?
+ ] [ drop f ] if
+] "custom-inlining" set-word-prop
+
+: rem-custom-inlining ( #call -- quot/f )
+ second value-info literal>> dup integer?
+ [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
+
+{
+ mod-integer-integer
+ mod-integer-fixnum
+ mod-fixnum-integer
+ fixnum-mod
+} [
+ [
+ in-d>> dup first value-info interval>> [0,inf] interval-subset?
+ [ rem-custom-inlining ] [ drop f ] if
+ ] "custom-inlining" set-word-prop
+] each
+
+\ rem [
+ in-d>> rem-custom-inlining
+] "custom-inlining" set-word-prop
+
+{
+ bitand-integer-integer
+ bitand-integer-fixnum
+ bitand-fixnum-integer
+ bitand
+} [
+ [
+ in-d>> second value-info >literal< [
+ 0 most-positive-fixnum between?
+ [ [ >fixnum ] bi@ fixnum-bitand ] f ?
+ ] when
+ ] "custom-inlining" set-word-prop
+] each
+
+! Speeds up 2^
+\ shift [
+ in-d>> first value-info literal>> 1 = [
+ cell-bits tag-bits get - 1 -
+ '[
+ >fixnum dup 0 < [ 2drop 0 ] [
+ dup _ < [ fixnum-shift ] [
+ fixnum-shift
+ ] if
+ ] if
+ ]
+ ] [ f ] if
+] "custom-inlining" set-word-prop
+
+! Generate more efficient code for common idiom
+\ clone [
+ in-d>> first value-info literal>> {
+ { V{ } [ [ drop { } 0 vector boa ] ] }
+ { H{ } [ [ drop 0 <hashtable> ] ] }
+ [ drop f ]
+ } case
+] "custom-inlining" set-word-prop
+
+ERROR: bad-partial-eval quot word ;
+
+: check-effect ( quot word -- )
+ 2dup [ infer ] [ stack-effect ] bi* effect<=
+ [ 2drop ] [ bad-partial-eval ] if ;
+
+:: define-partial-eval ( word quot n -- )
+ word [
+ in-d>> n tail*
+ [ value-info ] map
+ dup [ literal?>> ] all? [
+ [ literal>> ] map
+ n firstn
+ quot call dup [
+ [ n ndrop ] prepose
+ dup word check-effect
+ ] when
+ ] [ drop f ] if
+ ] "custom-inlining" set-word-prop ;
+
+: inline-new ( class -- quot/f )
+ dup tuple-class? [
+ dup inlined-dependency depends-on
+ [ all-slots [ initial>> literalize ] map ]
+ [ tuple-layout '[ _ <tuple-boa> ] ]
+ bi append >quotation
+ ] [ drop f ] if ;
+
+\ new [ inline-new ] 1 define-partial-eval
+
+\ instance? [
+ dup class?
+ [ "predicate" word-prop ] [ drop f ] if
+] 1 define-partial-eval
+
+! Shuffling
+: nths-quot ( indices -- quot )
+ [ [ '[ _ swap nth ] ] map ] [ length ] bi
+ '[ _ cleave _ narray ] ;
+
+\ shuffle [
+ shuffle-mapping nths-quot
+] 1 define-partial-eval
+
+! Index search
+\ index [
+ dup sequence? [
+ dup length 4 >= [
+ dup length zip >hashtable '[ _ at ]
+ ] [ drop f ] if
+ ] [ drop f ] if
+] 1 define-partial-eval
+
+: memq-quot ( seq -- newquot )
+ [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
+ [ drop f ] suffix [ cond ] curry ;
+
+\ memq? [
+ dup sequence? [ memq-quot ] [ drop f ] if
+] 1 define-partial-eval
+
+! Membership testing
+: member-quot ( seq -- newquot )
+ dup length 4 <= [
+ [ drop f ] swap
+ [ literalize [ t ] ] { } map>assoc linear-case-quot
+ ] [
+ unique [ key? ] curry
+ ] if ;
+
+\ member? [
+ dup sequence? [ member-quot ] [ drop f ] if
+] 1 define-partial-eval
+
+! Fast at for integer maps
+CONSTANT: lookup-table-at-max 256
+
+: lookup-table-at? ( assoc -- ? )
+ #! Can we use a fast byte array test here?
+ {
+ [ assoc-size 4 > ]
+ [ values [ ] all? ]
+ [ keys [ integer? ] all? ]
+ [ keys [ 0 lookup-table-at-max between? ] all? ]
+ } 1&& ;
+
+: lookup-table-seq ( assoc -- table )
+ [ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
+
+: lookup-table-quot ( seq -- newquot )
+ lookup-table-seq
+ '[
+ _ over integer? [
+ 2dup bounds-check? [
+ nth-unsafe dup >boolean
+ ] [ 2drop f f ] if
+ ] [ 2drop f f ] if
+ ] ;
+
+: fast-lookup-table-at? ( assoc -- ? )
+ values {
+ [ [ integer? ] all? ]
+ [ [ 0 254 between? ] all? ]
+ } 1&& ;
+
+: fast-lookup-table-seq ( assoc -- table )
+ lookup-table-seq [ 255 or ] B{ } map-as ;
+
+: fast-lookup-table-quot ( seq -- newquot )
+ fast-lookup-table-seq
+ '[
+ _ over integer? [
+ 2dup bounds-check? [
+ nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
+ ] [ 2drop f f ] if
+ ] [ 2drop f f ] if
+ ] ;
+
+: at-quot ( assoc -- quot )
+ dup lookup-table-at? [
+ dup fast-lookup-table-at? [
+ fast-lookup-table-quot
+ ] [
+ lookup-table-quot
+ ] if
+ ] [ drop f ] if ;
+
+\ at* [ at-quot ] 1 define-partial-eval
yield-hook [ [ ] ] initialize
: alist-max ( alist -- pair )
- [ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
\ No newline at end of file
+ [ ] [ [ [ second ] bi@ > ] most ] map-reduce ;
+
+: penultimate ( seq -- elt ) [ length 2 - ] keep nth ;
HOOK: %or-imm cpu ( dst src1 src2 -- )
HOOK: %xor cpu ( dst src1 src2 -- )
HOOK: %xor-imm cpu ( dst src1 src2 -- )
+HOOK: %shl cpu ( dst src1 src2 -- )
HOOK: %shl-imm cpu ( dst src1 src2 -- )
+HOOK: %shr cpu ( dst src1 src2 -- )
HOOK: %shr-imm cpu ( dst src1 src2 -- )
+HOOK: %sar cpu ( dst src1 src2 -- )
HOOK: %sar-imm cpu ( dst src1 src2 -- )
HOOK: %not cpu ( dst src -- )
HOOK: %log2 cpu ( dst src -- )
-HOOK: %fixnum-add cpu ( src1 src2 -- )
-HOOK: %fixnum-add-tail cpu ( src1 src2 -- )
-HOOK: %fixnum-sub cpu ( src1 src2 -- )
-HOOK: %fixnum-sub-tail cpu ( src1 src2 -- )
-HOOK: %fixnum-mul cpu ( src1 src2 temp1 temp2 -- )
-HOOK: %fixnum-mul-tail cpu ( src1 src2 temp1 temp2 -- )
+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 -- )
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: locals alien.c-types alien.syntax arrays kernel
+USING: locals alien.c-types alien.syntax arrays kernel fry
math namespaces sequences system layouts io vocabs.loader
accessors init combinators command-line cpu.x86.assembler
cpu.x86 cpu.architecture make compiler compiler.units
M:: x86.32 %dispatch ( src temp -- )
! Load jump table base.
- src HEX: ffffffff ADD
+ temp src HEX: ffffffff [+] LEA
+ building get length cell - :> start
0 rc-absolute-cell rel-here
! Go
- src HEX: 7f [+] JMP
+ temp HEX: 7f [+] JMP
+ building get length :> end
! Fix up the displacement above
cell code-alignment
- [ 7 + building get dup pop* push ]
+ [ end start - + building get dup pop* push ]
[ align-code ]
bi ;
M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
-M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ;
-
M: x86.32 return-struct-in-registers? ( c-type -- ? )
c-type
[ return-in-registers?>> ]
align-stack incr-stack-reg ;
: with-aligned-stack ( n quot -- )
- [ [ align-sub ] [ call ] bi* ]
- [ [ align-add ] [ drop ] bi* ] 2bi ; inline
+ '[ align-sub @ ] [ align-add ] bi ; inline
M: x86.32 %prologue ( n -- )
dup PUSH
0 PUSH rc-absolute-cell rel-this
- stack-reg swap 3 cells - SUB ;
+ 3 cells - decr-stack-reg ;
M: object %load-param-reg 3drop ;
M: x86.64 stack-reg RSP ;
M:: x86.64 %dispatch ( src temp -- )
+ building get length :> start
! Load jump table base.
temp HEX: ffffffff MOV
0 rc-absolute-cell rel-here
! Add jump table base
- src temp ADD
- src HEX: 7f [+] JMP
+ temp src ADD
+ temp HEX: 7f [+] JMP
+ building get length :> end
! Fix up the displacement above
cell code-alignment
- [ 15 + building get dup pop* push ]
+ [ end start - 2 - + building get dup pop* push ]
[ align-code ]
bi ;
rc-absolute-cell rel-dlsym
R11 CALL ;
-M: x86.64 %alien-invoke-tail
- R11 0 MOV
- rc-absolute-cell rel-dlsym
- R11 JMP ;
-
M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
RBP RAX MOV ;
cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
kernel kernel.private math memory namespaces make sequences
words system layouts combinators math.order fry locals
-compiler.constants compiler.cfg.registers
-compiler.cfg.instructions compiler.cfg.intrinsics
-compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup ;
+compiler.constants
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.intrinsics
+compiler.cfg.comparisons
+compiler.cfg.stack-frame
+compiler.codegen
+compiler.codegen.fixup ;
IN: cpu.x86
<< enable-fixnum-log2 >>
: ?MOV ( dst src -- )
2dup = [ 2drop ] [ MOV ] if ; inline
-:: move>args ( src1 src2 -- )
- {
- { [ src1 param-reg-2 = ] [ param-reg-1 src2 ?MOV param-reg-1 param-reg-2 XCHG ] }
- { [ src1 param-reg-1 = ] [ param-reg-2 src2 ?MOV ] }
- { [ src2 param-reg-1 = ] [ param-reg-2 src1 ?MOV param-reg-1 param-reg-2 XCHG ] }
- { [ src2 param-reg-2 = ] [ param-reg-1 src1 ?MOV ] }
- [
- param-reg-1 src1 MOV
- param-reg-2 src2 MOV
- ]
- } cond ;
-
-HOOK: %alien-invoke-tail cpu ( func dll -- )
-
-:: overflow-template ( src1 src2 insn inverse func -- )
- <label> "no-overflow" set
+:: overflow-template ( label dst src1 src2 insn -- )
src1 src2 insn call
- ds-reg [] src1 MOV
- "no-overflow" get JNO
- src1 src2 inverse call
- src1 src2 move>args
- %prepare-alien-invoke
- func f %alien-invoke
- "no-overflow" resolve-label ; inline
+ label JO ; inline
-:: overflow-template-tail ( src1 src2 insn inverse func -- )
- <label> "no-overflow" set
- src1 src2 insn call
- "no-overflow" get JNO
- src1 src2 inverse call
- src1 src2 move>args
- %prepare-alien-invoke
- func f %alien-invoke-tail
- "no-overflow" resolve-label
- ds-reg [] src1 MOV
- 0 RET ; inline
-
-M: x86 %fixnum-add ( src1 src2 -- )
- [ ADD ] [ SUB ] "overflow_fixnum_add" overflow-template ;
-
-M: x86 %fixnum-add-tail ( src1 src2 -- )
- [ ADD ] [ SUB ] "overflow_fixnum_add" overflow-template-tail ;
-
-M: x86 %fixnum-sub ( src1 src2 -- )
- [ SUB ] [ ADD ] "overflow_fixnum_subtract" overflow-template ;
-
-M: x86 %fixnum-sub-tail ( src1 src2 -- )
- [ SUB ] [ ADD ] "overflow_fixnum_subtract" overflow-template-tail ;
-
-M:: x86 %fixnum-mul ( src1 src2 temp1 temp2 -- )
- "no-overflow" define-label
- temp1 src1 MOV
- temp1 tag-bits get SAR
- src2 temp1 IMUL2
- ds-reg [] temp1 MOV
- "no-overflow" get JNO
- src1 src2 move>args
- param-reg-1 tag-bits get SAR
- param-reg-2 tag-bits get SAR
- %prepare-alien-invoke
- "overflow_fixnum_multiply" f %alien-invoke
- "no-overflow" resolve-label ;
-
-M:: x86 %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
- "overflow" define-label
- temp1 src1 MOV
- temp1 tag-bits get SAR
- src2 temp1 IMUL2
- "overflow" get JO
- ds-reg [] temp1 MOV
- 0 RET
- "overflow" resolve-label
- src1 src2 move>args
- param-reg-1 tag-bits get SAR
- param-reg-2 tag-bits get SAR
- %prepare-alien-invoke
- "overflow_fixnum_multiply" f %alien-invoke-tail ;
+M: x86 %fixnum-add ( label dst src1 src2 -- )
+ [ ADD ] overflow-template ;
+
+M: x86 %fixnum-sub ( label dst src1 src2 -- )
+ [ SUB ] overflow-template ;
+
+M: x86 %fixnum-mul ( label dst src1 src2 -- )
+ [ swap IMUL2 ] overflow-template ;
: bignum@ ( reg n -- op )
cells bignum tag-number - [+] ; inline
[ quot call ] with-save/restore
] if ; inline
+: shift-count? ( reg -- ? ) { ECX RCX } memq? ;
+
+:: emit-shift ( dst src1 src2 quot -- )
+ src2 shift-count? [
+ dst CL quot call
+ ] [
+ dst shift-count? [
+ dst src2 XCHG
+ src2 CL quot call
+ dst src2 XCHG
+ ] [
+ ECX small-reg-native [
+ CL src2 MOV
+ drop dst CL quot call
+ ] with-save/restore
+ ] if
+ ] if ; inline
+
+M: x86 %shl [ SHL ] emit-shift ;
+M: x86 %shr [ SHR ] emit-shift ;
+M: x86 %sar [ SAR ] emit-shift ;
+
M:: x86 %string-nth ( dst src index temp -- )
"end" define-label
dst { src index temp } [| new-dst |
M: no-word-error error. summary print ;
+M: no-word-in-vocab summary
+ [ vocab>> ] [ word>> ] bi
+ [ "No word named ``" % % "'' found in ``" % % "'' vocabulary" % ] "" make ;
+
+M: no-word-in-vocab error. summary print ;
+
M: ambiguous-use-error summary
words>> first name>>
"More than one vocabulary defines a word named ``" "''" surround ;
--- /dev/null
+IN: disjoint-sets.testes
+USING: tools.test disjoint-sets namespaces slots.private ;
+
+SYMBOL: +blah+
+-405534154 +blah+ 1 set-slot
+
+SYMBOL: uf
+
+[ ] [
+ <disjoint-set> uf set
+ +blah+ uf get add-atom
+ 19026 uf get add-atom
+ 19026 +blah+ uf get equate
+] unit-test
+
+[ 2 ] [ 19026 uf get equiv-set-size ] unit-test
USING: parser lexer kernel namespaces sequences definitions
io.files io.backend io.pathnames io summary continuations
tools.crossref vocabs.hierarchy prettyprint source-files
-source-files.errors assocs vocabs vocabs.loader splitting
+source-files.errors assocs vocabs.loader splitting
accessors debugger help.topics ;
+FROM: vocabs => vocab-name >vocab-link ;
IN: editors
TUPLE: no-edit-hook ;
SYMBOL: edit-hook
: available-editors ( -- seq )
- "editors" all-child-vocabs-seq [ vocab-name ] map ;
+ "editors" child-vocabs no-roots no-prefixes [ vocab-name ] map ;
: editor-restarts ( -- alist )
available-editors
[ "<p><a href=\"a\">a</a> <a href=\"b\">c</a></p>" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
-[ "<p><a href=\"C%2b%2b\">C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
+[ "<p><a href=\"C%2B%2B\">C++</a></p>" ] [ "[[C++]]" convert-farkup ] unit-test
[ "<p><foo></p>" ] [ "<foo>" convert-farkup ] unit-test
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.mixin classes.parser
-classes.tuple classes.tuple.parser combinators effects
-effects.parser fry generic generic.parser generic.standard
-interpolate io.streams.string kernel lexer locals.parser
-locals.rewrite.closures locals.types make macros namespaces
-parser quotations sequences vocabs.parser words words.symbol ;
+classes.singleton classes.tuple classes.tuple.parser
+combinators effects.parser fry generic generic.parser
+generic.standard interpolate io.streams.string kernel lexer
+locals.parser locals.types macros make namespaces parser
+quotations sequences vocabs.parser words words.symbol ;
IN: functors
! This is a hack
} case
\ define-tuple-class parsed ;
+SYNTAX: `SINGLETON:
+ scan-param parsed
+ \ define-singleton-class parsed ;
+
+SYNTAX: `MIXIN:
+ scan-param parsed
+ \ define-mixin-class parsed ;
+
SYNTAX: `M:
scan-param parsed
scan-param parsed
SYNTAX: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ;
+SYNTAX: DEFERS [ current-vocab create ] (INTERPOLATE) ;
+
SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ;
SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;
: functor-words ( -- assoc )
H{
{ "TUPLE:" POSTPONE: `TUPLE: }
+ { "SINGLETON:" POSTPONE: `SINGLETON: }
+ { "MIXIN:" POSTPONE: `MIXIN: }
{ "M:" POSTPONE: `M: }
{ "C:" POSTPONE: `C: }
{ ":" POSTPONE: `: }
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences arrays assocs sequences.private
-growable accessors math.order summary ;
+growable accessors math.order summary vectors ;
IN: heaps
GENERIC: heap-push* ( value key heap -- entry )
<PRIVATE
-TUPLE: heap data ;
+TUPLE: heap { data vector } ;
: <heap> ( class -- heap )
[ V{ } clone ] dip boa ; inline
TUPLE: entry value key heap index ;
-: <entry> ( value key heap -- entry ) f entry boa ;
+: <entry> ( value key heap -- entry ) f entry boa ; inline
PRIVATE>
[ data-exchange ] 2keep up-heap
] [
3drop
- ] if ;
+ ] if ; inline recursive
: up-heap ( n heap -- )
- over 0 > [ (up-heap) ] [ 2drop ] if ;
+ over 0 > [ (up-heap) ] [ 2drop ] if ; inline recursive
: (child) ( m heap -- n )
2dup right-value
3drop
] [
[ data-exchange ] 2keep down-heap
- ] if ;
+ ] if ; inline recursive
: down-heap ( m heap -- )
- 2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ;
+ 2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ; inline recursive
PRIVATE>
[ swapd heap-push ] curry assoc-each ;
: >entry< ( entry -- key value )
- [ value>> ] [ key>> ] bi ;
+ [ value>> ] [ key>> ] bi ; inline
M: heap heap-peek ( heap -- value key )
data-first >entry< ;
[ dup name>> >lower ] { } map>assoc ;
: vocab-candidates ( -- candidates )
- all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
+ all-vocabs-recursive no-roots no-prefixes
+ [ dup vocab-name >lower ] { } map>assoc ;
: help-candidates ( seq -- candidates )
[ [ >link ] [ article-title >lower ] bi ] { } map>assoc
assocs sequences make words accessors arrays help.topics vocabs
vocabs.hierarchy help.vocabs namespaces prettyprint io
vocabs.loader serialize fry memoize unicode.case math.order
-sorting debugger html xml.syntax xml.writer math.parser ;
+sorting debugger html xml.syntax xml.writer math.parser
+sets hashtables ;
FROM: io.encodings.ascii => ascii ;
FROM: ascii => ascii? ;
IN: help.html
{ CHAR: / "__slash__" }
{ CHAR: , "__comma__" }
{ CHAR: @ "__at__" }
+ { CHAR: # "__hash__" }
} at [ % ] [ , ] ?if
] [ number>string "__" "__" surround % ] if ;
dup topic>filename utf8 [ help>html write-xml ] with-file-writer ;
: all-vocabs-really ( -- seq )
- #! Hack.
- all-vocabs values concat
- vocabs [ find-vocab-root not ] filter [ vocab ] map append ;
+ all-vocabs >hashtable f over delete-at no-roots remove-redundant-prefixes ;
: all-topics ( -- topics )
[
swap '[
_ elements [
rest { { } { "" } } member?
- [ "Empty description" throw ] when
+ [ "Empty $description" simple-lint-error ] when
] each
] each ;
source-files.errors vocabs.hierarchy vocabs words classes
locals tools.errors listener ;
FROM: help.lint.checks => all-vocabs ;
+FROM: vocabs => child-vocabs ;
IN: help.lint
SYMBOL: lint-failures
: help-lint ( prefix -- )
[
auto-use? off
- all-vocabs-seq [ vocab-name ] map all-vocabs set
+ all-vocab-names all-vocabs set
group-articles vocab-articles set
child-vocabs
[ check-vocab ] each
make namespaces prettyprint sequences sets sorting summary
vocabs vocabs.files vocabs.hierarchy vocabs.loader
vocabs.metadata words words.symbol definitions.icons ;
+FROM: vocabs.hierarchy => child-vocabs ;
IN: help.vocabs
: about ( vocab -- )
$heading ;
: $vocabs ( seq -- )
- [ vocab-row ] map vocab-headings prefix $table ;
+ convert-prefixes [ vocab-row ] map vocab-headings prefix $table ;
: $vocab-roots ( assoc -- )
[
] unless-empty ;
: describe-children ( vocab -- )
- vocab-name all-child-vocabs $vocab-roots ;
+ vocab-name child-vocabs
+ $vocab-roots ;
: files. ( seq -- )
snippet-style get [
{ version "1.1" }
{ cookies V{ } }
{ header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } }
+ { redirects 10 }
}
] [
"http://www.apple.com/index.html"
{ version "1.1" }
{ cookies V{ } }
{ header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } }
+ { redirects 10 }
}
] [
"https://www.amazon.com/index.html"
ERROR: too-many-redirects ;
-CONSTANT: max-redirects 10
-
<PRIVATE
: write-request-line ( request -- request )
:: do-redirect ( quot: ( chunk -- ) response -- response )
redirects inc
- redirects get max-redirects < [
+ redirects get request get redirects>> < [
request get clone
response "location" header redirect-url
response code>> 307 = [ "GET" >>method ] unless
with-output-stream*
] [
in>> [
- read-response dup redirect? [ t ] [
+ read-response dup redirect?
+ request get redirects>> 0 > and [ t ] [
[ nip response set ]
[ read-response-body ]
[ ]
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel summary debugger io make math.parser
-prettyprint http.client accessors ;
+prettyprint http http.client accessors ;
IN: http.client.debugger
M: too-many-redirects summary
{ { $slot "header" } { "An assoc of HTTP header values. See " { $link "http.headers" } } }
{ { $slot "post-data" } { "See " { $link "http.post-data" } } }
{ { $slot "cookies" } { "A sequence of HTTP cookies. See " { $link "http.cookies" } } }
+ { { $slot "redirects" } { "Number of redirects to attempt before throwing an error. Default is " { $snippet "max-redirects" } " ." } }
} } ;
HELP: <response>
{ header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } }
{ post-data T{ post-data { data "blah" } { content-type "application/octet-stream" } } }
{ cookies V{ } }
+ { redirects 10 }
}
] [
read-request-test-1 lf>crlf [
{ version "1.1" }
{ header H{ { "host" "www.sex.com" } } }
{ cookies V{ } }
+ { redirects 10 }
}
] [
read-request-test-2 lf>crlf [
base64 ;
IN: http
+CONSTANT: max-redirects 10
+
: (read-header) ( -- alist )
[ read-crlf dup f like ] [ parse-header-line ] produce nip ;
version
header
post-data
-cookies ;
+cookies
+redirects ;
: set-header ( request/response value key -- request/response )
pick header>> set-at ;
H{ } clone >>header
V{ } clone >>cookies
"close" "connection" set-header
- "Factor http.client" "user-agent" set-header ;
+ "Factor http.client" "user-agent" set-header
+ max-redirects >>redirects ;
: header ( request/response key -- value )
swap header>> at ;
INTENSITY DEPTH DEPTH-STENCIL R RG ;
UNION: component-type
- ubyte-components ushort-components
+ ubyte-components ushort-components uint-components
half-components float-components
byte-integer-components ubyte-integer-components
short-integer-components ushort-integer-components
short-integer-components ushort-integer-components
int-integer-components uint-integer-components ;
+UNION: signed-unnormalized-integer-components
+ byte-integer-components
+ short-integer-components
+ int-integer-components ;
+
+UNION: unsigned-unnormalized-integer-components
+ ubyte-integer-components
+ ushort-integer-components
+ uint-integer-components ;
+
UNION: packed-components
u-5-5-5-1-components u-5-6-5-components
u-10-10-10-2-components
{ RG [ 2 ] }
} case ;
-: bytes-per-pixel ( image -- n )
- dup component-type>> packed-components?
- [ component-type>> bytes-per-packed-pixel ] [
- [ component-order>> component-count ]
- [ component-type>> bytes-per-component ] bi *
+: (bytes-per-pixel) ( component-order component-type -- n )
+ dup packed-components?
+ [ nip bytes-per-packed-pixel ] [
+ [ component-count ] [ bytes-per-component ] bi* *
] if ;
+: bytes-per-pixel ( image -- n )
+ [ component-order>> ] [ component-type>> ] bi (bytes-per-pixel) ;
+
<PRIVATE
: pixel@ ( x y image -- start end bitmap )
{ [ os winnt? ] [ "io.launcher.windows.nt" require ] }
[ ]
} cond
-
-: run-desc ( desc -- result ) utf8 [ contents [ but-last ] [ f ] if* ] with-process-reader ;
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays columns kernel math math.bits
-math.order math.vectors sequences sequences.private fry ;
+USING: accessors arrays columns kernel locals math math.bits
+math.functions math.order math.vectors sequences
+sequences.private fry ;
IN: math.matrices
! Matrices
#! Make a nxn identity matrix.
dup [ [ = 1 0 ? ] with map ] curry map ;
+:: rotation-matrix3 ( axis theta -- matrix )
+ theta cos :> c
+ theta sin :> s
+ axis first3 :> z :> y :> x
+ x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 3array
+ x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 3array
+ x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 3array
+ 3array ;
+
+:: rotation-matrix4 ( axis theta -- matrix )
+ theta cos :> c
+ theta sin :> s
+ axis first3 :> z :> y :> x
+ x sq 1.0 x sq - c * + x y * 1.0 c - * z s * - x z * 1.0 c - * y s * + 0 4array
+ x y * 1.0 c - * z s * + y sq 1.0 y sq - c * + y z * 1.0 c - * x s * - 0 4array
+ x z * 1.0 c - * y s * - y z * 1.0 c - * x s * + z sq 1.0 z sq - c * + 0 4array
+ { 0.0 0.0 0.0 1.0 } 4array ;
+
+:: translation-matrix4 ( offset -- matrix )
+ offset first3 :> z :> y :> x
+ {
+ { 1.0 0.0 0.0 x }
+ { 0.0 1.0 0.0 y }
+ { 0.0 0.0 1.0 z }
+ { 0.0 0.0 0.0 1.0 }
+ } ;
+
+: >scale-factors ( number/sequence -- x y z )
+ dup number? [ dup dup ] [ first3 ] if ;
+
+:: scale-matrix3 ( factors -- matrix )
+ factors >scale-factors :> z :> y :> x
+ {
+ { x 0.0 0.0 }
+ { 0.0 y 0.0 }
+ { 0.0 0.0 z }
+ } ;
+
+:: scale-matrix4 ( factors -- matrix )
+ factors >scale-factors :> z :> y :> x
+ {
+ { x 0.0 0.0 0.0 }
+ { 0.0 y 0.0 0.0 }
+ { 0.0 0.0 z 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } ;
+
+: ortho-matrix4 ( dim -- matrix )
+ [ recip ] map scale-matrix4 ;
+
+:: frustum-matrix4 ( xy-dim near far -- matrix )
+ xy-dim first2 :> y :> x
+ near x /f :> xf
+ near y /f :> yf
+ near far + near far - /f :> zf
+ 2 near far * * near far - /f :> wf
+
+ {
+ { xf 0.0 0.0 0.0 }
+ { 0.0 yf 0.0 0.0 }
+ { 0.0 0.0 zf wf }
+ { 0.0 0.0 -1.0 0.0 }
+ } ;
+
+:: skew-matrix4 ( theta -- matrix )
+ theta tan :> zf
+
+ {
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 1.0 0.0 0.0 }
+ { 0.0 zf 1.0 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } ;
+
! Matrix operations
: mneg ( m -- m ) [ vneg ] map ;
PRIVATE>
-: cross ( vec1 vec2 -- vec3 ) [ i ] [ j ] [ k ] 2tri 3array ;
+: cross ( vec1 vec2 -- vec3 ) [ [ i ] [ j ] [ k ] 2tri ] keep 3sequence ;
: proj ( v u -- w )
[ [ v. ] [ norm-sq ] bi / ] keep n*v ;
USING: help.markup help.syntax math sequences ;
IN: math.primes.factors
-{ factors group-factors unique-factors } related-words
+{ divisors factors group-factors unique-factors } related-words
HELP: factors
{ $values { "n" "a positive integer" } { "seq" sequence } }
HELP: totient
{ $values { "n" "a positive integer" } { "t" integer } }
{ $description { "Return the number of integers between 1 and " { $snippet "n-1" } " that are relatively prime to " { $snippet "n" } "." } } ;
+
+HELP: divisors
+{ $values { "n" "a positive integer" } { "seq" sequence } }
+{ $description { "Return the ordered list of divisors of " { $snippet "n" } ", including 1 and " { $snippet "n" } "." } } ;
-USING: math.primes.factors tools.test ;
+USING: math.primes.factors sequences tools.test ;
{ { 999983 999983 1000003 } } [ 999969000187000867 factors ] unit-test
{ { } } [ -5 factors ] unit-test
{ 0 } [ 1 totient ] unit-test
{ { 425612003 } } [ 425612003 factors ] unit-test
{ { 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
! Copyright (C) 2007-2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel make math math.functions
-math.primes sequences ;
+math.primes math.ranges sequences sequences.product sorting ;
IN: math.primes.factors
<PRIVATE
{ [ dup 2 < ] [ drop 0 ] }
[ dup unique-factors [ 1 [ 1- * ] reduce ] [ product ] bi / * ]
} cond ; foldable
+
+: divisors ( n -- seq )
+ group-factors [ first2 [0,b] [ ^ ] with map ] map
+ [ product ] product-map natural-sort ;
[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test
[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test
+
+[ 17 ] [ 0 1 2 3 4 5 6 7 { 1 2 3 } trilerp ] unit-test
\ No newline at end of file
--- /dev/null
+USING: alien help.markup help.syntax io kernel math quotations
+opengl.gl assocs vocabs.loader sequences accessors colors words
+opengl ;
+IN: opengl.annotations
+
+HELP: log-gl-error
+{ $values { "function" word } }
+{ $description "If the most recent OpenGL call resulted in an error, append it to the " { $link gl-error-log } "." }
+{ $notes "Don't call this function directly. Call " { $link log-gl-errors } " to annotate every OpenGL function to automatically log errors." } ;
+
+HELP: gl-error-log
+{ $var-description "A vector of OpenGL errors logged by " { $link log-gl-errors } ". Each log entry has the following tuple slots:" }
+{ $list
+ { { $snippet "function" } " is the OpenGL function that raised the error." }
+ { { $snippet "error" } " is the OpenGL error code." }
+ { { $snippet "timestamp" } " is the time the error was logged." }
+}
+{ "The error log is emptied using the " { $link clear-gl-error-log } " word." } ;
+
+HELP: clear-gl-error-log
+{ $description "Empties the OpenGL error log populated by " { $link log-gl-errors } "." } ;
+
+HELP: throw-gl-errors
+{ $description "Annotate every OpenGL function to throw a " { $link gl-error } " if the function results in an error. Use " { $link reset-gl-functions } " to reverse this operation." } ;
+
+HELP: log-gl-errors
+{ $description "Annotate every OpenGL function to log using " { $link log-gl-error } " if the function results in an error. Use " { $link reset-gl-functions } " to reverse this operation." } ;
+
+HELP: reset-gl-functions
+{ $description "Removes any annotations from all OpenGL functions, such as those applied by " { $link throw-gl-errors } " or " { $link log-gl-errors } "." } ;
+
+{ throw-gl-errors gl-error log-gl-errors log-gl-error clear-gl-error-log reset-gl-functions } related-words
+
+ARTICLE: "opengl.annotations" "OpenGL error reporting"
+"The " { $vocab-link "opengl.annotations" } " vocabulary provides some tools for tracking down GL errors:"
+{ $subsection throw-gl-errors }
+{ $subsection log-gl-errors }
+{ $subsection clear-gl-error-log }
+{ $subsection reset-gl-functions } ;
+
+ABOUT: "opengl.annotations"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces combinators.short-circuit vocabs sequences
+compiler.units tools.annotations tools.annotations.private fry words
+opengl calendar accessors ascii ;
+IN: opengl.annotations
+
+TUPLE: gl-error-log
+ { function word initial: t }
+ { error gl-error }
+ { timestamp timestamp } ;
+
+gl-error-log [ V{ } clone ] initialize
+
+: <gl-error-log> ( function code -- gl-error-log )
+ [ dup ] dip <gl-error> now gl-error-log boa ;
+
+: log-gl-error ( function -- )
+ gl-error-code [ <gl-error-log> gl-error-log get push ] [ drop ] if* ;
+
+: clear-gl-error-log ( -- )
+ V{ } clone gl-error-log set ;
+
+: gl-function? ( word -- ? )
+ name>> { [ "glGetError" = not ] [ "gl" head? ] [ third LETTER? ] } 1&& ;
+
+: gl-functions ( -- words )
+ "opengl.gl" vocab words [ gl-function? ] filter ;
+
+: annotate-gl-functions ( quot -- )
+ [
+ [ gl-functions ] dip [ [ dup ] dip curry (annotate) ] curry each
+ ] with-compilation-unit ;
+
+: reset-gl-functions ( -- )
+ [ gl-functions [ (reset) ] each ] with-compilation-unit ;
+
+: throw-gl-errors ( -- )
+ [ '[ @ _ (gl-error) ] ] annotate-gl-functions ;
+
+: log-gl-errors ( -- )
+ [ '[ @ _ log-gl-error ] ] annotate-gl-functions ;
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: help.markup help.syntax multiline tools.continuations ;
+IN: opengl.debug
+
+HELP: G
+{ $description "Makes the OpenGL context associated with " { $link G-world } " active for subsequent OpenGL calls. This is intended to be used from the listener, where interactively entered OpenGL calls can be directed to any window. Note that the Factor UI resets the OpenGL context every time a window is updated, so every code snippet entered in the listener must be prefixed with " { $snippet "G" } " in this use case." }
+{ $examples { $code <" USING: opengl.debug ui ;
+
+[ drop t ] find-window G-world set
+G 0.0 0.0 1.0 1.0 glClearColor
+G GL_COLOR_BUFFER_BIT glClear
+"> } } ;
+
+HELP: F
+{ $description "Flushes the OpenGL context associated with " { $link G-world } ", thereby committing any outstanding drawing operations." } ;
+
+HELP: G-world
+{ $var-description "The world whose OpenGL context is made active by " { $link G } "." } ;
+
+HELP: GB
+{ $description "A shorthand for " { $link gl-break } "." } ;
+
+HELP: gl-break
+{ $description "Suspends the current thread and activates the walker like " { $link break } ", but also preserves the current OpenGL context, saves it to " { $link G-world } " for interactive use through " { $link G } ", and restores the current context when the suspended thread is continued. The shorthand word " { $link POSTPONE: GB } " can also be used." } ;
+
+{ G F G-world POSTPONE: GB gl-break } related-words
+
+ARTICLE: "opengl.debug" "Interactive debugging of OpenGL applications"
+"The " { $vocab-link "opengl.debug" } " vocabulary provides words to assist with interactive debugging of OpenGL applications in the Factor UI."
+{ $subsection G-world }
+{ $subsection G }
+{ $subsection F }
+{ $subsection GB }
+{ $subsection gl-break } ;
+
+ABOUT: "opengl.debug"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors kernel namespaces parser tools.continuations
+ui.backend ui.gadgets.worlds words ;
+IN: opengl.debug
+
+SYMBOL: G-world
+
+: G ( -- )
+ G-world get set-gl-context ;
+
+: F ( -- )
+ G-world get handle>> flush-gl-context ;
+
+: gl-break ( -- )
+ world get dup G-world set-global
+ [ break ] dip
+ set-gl-context ;
+
+<< \ gl-break t "break?" set-word-prop >>
+
+SYNTAX: GB
+ \ gl-break parsed ;
+
--- /dev/null
+Helper words for breaking and interactively manipulating OpenGL applications
USING: alien help.markup help.syntax io kernel math quotations
-opengl.gl assocs vocabs.loader sequences accessors colors ;
+opengl.gl assocs vocabs.loader sequences accessors colors words ;
IN: opengl
HELP: gl-color
{ $notes "See " { $link "colors" } "." } ;
HELP: gl-error
-{ $description "If the most recent OpenGL call resulted in an error, print the error to " { $link output-stream } "." } ;
+{ $description "If the most recent OpenGL call resulted in an error, throw a " { $snippet "gl-error" } " instance reporting the error." } ;
HELP: do-enabled
{ $values { "what" integer } { "quot" quotation } }
$nl
"The " { $vocab-link "opengl.gl" } " and " { $vocab-link "opengl.glu" } " vocabularies have the actual OpenGL bindings."
{ $subsection "opengl-low-level" }
+"Error reporting:"
+{ $subsection gl-error }
"Wrappers:"
{ $subsection gl-color }
{ $subsection gl-translate }
! Portions copyright (C) 2007 Eduardo Cavazos.
! Portions copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types continuations kernel libc math macros
-namespaces math.vectors math.parser opengl.gl combinators
-combinators.smart arrays sequences splitting words byte-arrays assocs
+USING: alien alien.c-types ascii calendar combinators.short-circuit
+continuations kernel libc math macros namespaces math.vectors
+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 ;
IN: opengl
{ HEX: 0506 "Invalid framebuffer operation" }
} at "Unknown error" or ;
-TUPLE: gl-error code string ;
+TUPLE: gl-error function code string ;
+
+: <gl-error> ( function code -- gl-error )
+ dup error>string \ gl-error boa ; inline
+
+: gl-error-code ( -- code/f )
+ glGetError dup 0 = [ drop f ] when ; inline
+
+: (gl-error) ( function -- )
+ gl-error-code [ <gl-error> throw ] [ drop ] if* ;
: gl-error ( -- )
- glGetError dup 0 = [ drop ] [
- dup error>string \ gl-error boa throw
- ] if ;
+ f (gl-error) ; inline
: do-enabled ( what quot -- )
over glEnable dip glDisable ; inline
: (gen-gl-object) ( quot -- id )
[ 1 0 <uint> ] dip keep *uint ; inline
-: gen-gl-buffer ( -- id )
- [ glGenBuffers ] (gen-gl-object) ;
-
: (delete-gl-object) ( id quot -- )
[ 1 swap <uint> ] dip call ; inline
+: gen-gl-buffer ( -- id )
+ [ glGenBuffers ] (gen-gl-object) ;
+
: delete-gl-buffer ( id -- )
[ glDeleteBuffers ] (delete-gl-object) ;
GL_ARRAY_BUFFER swap _ with-gl-buffer
] with-gl-buffer ; inline
+: gen-vertex-array ( -- id )
+ [ glGenVertexArrays ] (gen-gl-object) ;
+
+: delete-vertex-array ( id -- )
+ [ glDeleteVertexArrays ] (delete-gl-object) ;
+
+:: with-vertex-array ( id quot -- )
+ id glBindVertexArray
+ quot [ 0 glBindVertexArray ] [ ] cleanup ; inline
+
: <gl-buffer> ( target data hint -- id )
pick gen-gl-buffer [
[
[ "Hi" ] [ "Hi" present ] unit-test
[ "+" ] [ \ + present ] unit-test
[ "kernel" ] [ "kernel" vocab present ] unit-test
-[ ] [ all-vocabs-seq [ present ] map drop ] unit-test
\ No newline at end of file
+[ ] [ all-vocabs-recursive no-roots no-prefixes [ present ] map drop ] unit-test
\ No newline at end of file
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.alien
+
+<< "ptrdiff_t" define-array >>
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: functors sequences sequences.private growable
+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
<A> IS <${A}>
-V DEFINES-CLASS ${T}-vector
-<V> DEFINES <${V}>
->V DEFINES >${V}
+>V DEFERS >${V}
V{ DEFINES ${V}{
WHERE
-TUPLE: V { underlying A } { length array-capacity } ;
-
-: <V> ( capacity -- vector ) <A> 0 V boa ; inline
-
-M: V like
- drop dup V instance? [
- dup A instance? [ dup length V boa ] [ >V ] if
- ] unless ;
-
-M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
-
-M: A new-resizable drop <V> ;
+V A <A> vectors.functor:define-vector
-M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
+M: V contract 2drop ;
-: >V ( seq -- vector ) V new clone-like ; inline
+M: V byte-length underlying>> byte-length ;
M: V pprint-delims drop \ V{ \ } ;
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-USING: stack-checker.call-effect tools.test kernel math effects ;
-IN: stack-checker.call-effect.tests
-
-[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
-[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
-[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
-[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
-
-[ t ] [ [ + ] cached-effect (( a b -- c )) effect= ] unit-test
-[ t ] [ 5 [ + ] curry cached-effect (( a -- c )) effect= ] unit-test
-[ t ] [ 5 [ ] curry cached-effect (( -- c )) effect= ] unit-test
-[ t ] [ [ dup ] [ drop ] compose cached-effect (( a -- b )) effect= ] unit-test
-[ t ] [ [ drop ] [ dup ] compose cached-effect (( a b -- c d )) effect= ] unit-test
-[ t ] [ [ 2drop ] [ dup ] compose cached-effect (( a b c -- d e )) effect= ] unit-test
-[ t ] [ [ 1 2 3 ] [ 2drop ] compose cached-effect (( -- a )) effect= ] unit-test
-[ t ] [ [ 1 2 ] [ 3drop ] compose cached-effect (( a -- )) effect= ] 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 combinators combinators.private effects fry
-kernel kernel.private make sequences continuations quotations
-stack-checker stack-checker.transforms words math ;
-IN: stack-checker.call-effect
-
-! call( and execute( have complex expansions.
-
-! call( uses the following strategy:
-! - Inline caching. If the quotation is the same as last time, just call it unsafely
-! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot,
-! and compare it with declaration. If matches, call it unsafely.
-! - Fallback. If the above doesn't work, call it and compare the datastack before
-! and after to make sure it didn't mess anything up.
-
-! execute( uses a similar strategy.
-
-TUPLE: inline-cache value ;
-
-: cache-hit? ( word/quot ic -- ? )
- [ value>> eq? ] [ value>> ] bi and ; inline
-
-SINGLETON: +unknown+
-
-GENERIC: cached-effect ( quot -- effect )
-
-M: object cached-effect drop +unknown+ ;
-
-GENERIC: curry-effect ( effect -- effect' )
-
-M: +unknown+ curry-effect ;
-
-M: effect curry-effect
- [ in>> length ] [ out>> length ] [ terminated?>> ] tri
- pick 0 = [ [ 1+ ] dip ] [ [ 1- ] 2dip ] if
- effect boa ;
-
-M: curry cached-effect
- quot>> cached-effect curry-effect ;
-
-: compose-effects* ( effect1 effect2 -- effect' )
- {
- { [ 2dup [ effect? ] both? ] [ compose-effects ] }
- { [ 2dup [ +unknown+ eq? ] either? ] [ 2drop +unknown+ ] }
- } cond ;
-
-M: compose cached-effect
- [ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
-
-M: quotation cached-effect
- dup cached-effect>>
- [ ] [
- [ [ infer ] [ 2drop +unknown+ ] recover dup ] keep
- (>>cached-effect)
- ] ?if ;
-
-: call-effect-unsafe? ( quot effect -- ? )
- [ cached-effect ] dip
- over +unknown+ eq?
- [ 2drop f ] [ effect<= ] if ; inline
-
-: (call-effect-slow>quot) ( in out effect -- quot )
- [
- [ [ datastack ] dip dip ] %
- [ [ , ] bi@ \ check-datastack , ] dip
- '[ _ wrong-values ] , \ unless ,
- ] [ ] make ;
-
-: call-effect-slow>quot ( effect -- quot )
- [ in>> length ] [ out>> length ] [ ] tri
- [ (call-effect-slow>quot) ] keep add-effect-input
- [ call-effect-unsafe ] 2curry ;
-
-: call-effect-slow ( quot effect -- ) drop call ;
-
-\ call-effect-slow [ call-effect-slow>quot ] 1 define-transform
-
-\ call-effect-slow t "no-compile" set-word-prop
-
-: call-effect-fast ( quot effect inline-cache -- )
- 2over call-effect-unsafe?
- [ [ nip (>>value) ] [ drop call-effect-unsafe ] 3bi ]
- [ drop call-effect-slow ]
- if ; inline
-
-\ call-effect [
- inline-cache new '[
- _
- 3dup nip cache-hit? [
- drop call-effect-unsafe
- ] [
- call-effect-fast
- ] if
- ]
-] 0 define-transform
-
-\ call-effect t "no-compile" set-word-prop
-
-: execute-effect-slow ( word effect -- )
- [ '[ _ execute ] ] dip call-effect-slow ; inline
-
-: execute-effect-unsafe? ( word effect -- ? )
- over optimized? [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
-
-: execute-effect-fast ( word effect inline-cache -- )
- 2over execute-effect-unsafe?
- [ [ nip (>>value) ] [ drop execute-effect-unsafe ] 3bi ]
- [ drop execute-effect-slow ]
- if ; inline
-
-: execute-effect-ic ( word effect inline-cache -- )
- 3dup nip cache-hit?
- [ drop execute-effect-unsafe ]
- [ execute-effect-fast ]
- if ; inline
-
-: execute-effect>quot ( effect -- quot )
- inline-cache new '[ _ _ execute-effect-ic ] ;
-
-\ execute-effect [ execute-effect>quot ] 1 define-transform
-
-\ execute-effect t "no-compile" set-word-prop
\ No newline at end of file
Slava Pestov
+Daniel Ehrenberg
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors alien alien.accessors arrays byte-arrays classes
continuations.private effects generic hashtables
[ length ensure-d ] keep zip
#declare, ;
+\ declare [ infer-declare ] "special" set-word-prop
+
GENERIC: infer-call* ( value known -- )
: (infer-call) ( value -- ) dup known infer-call* ;
: infer-call ( -- ) pop-d (infer-call) ;
+\ call [ infer-call ] "special" set-word-prop
+
+\ (call) [ infer-call ] "special" set-word-prop
+
M: literal infer-call*
[ 1array #drop, ] [ infer-literal-quot ] bi* ;
: infer-dip ( -- ) \ dip 1 infer-ndip ;
+\ dip [ infer-dip ] "special" set-word-prop
+
: infer-2dip ( -- ) \ 2dip 2 infer-ndip ;
+\ 2dip [ infer-2dip ] "special" set-word-prop
+
: infer-3dip ( -- ) \ 3dip 3 infer-ndip ;
+\ 3dip [ infer-3dip ] "special" set-word-prop
+
: infer-builder ( quot word -- )
[
[ 2 consume-d ] dip
: infer-curry ( -- ) [ <curried> ] \ curry infer-builder ;
+\ curry [ infer-curry ] "special" set-word-prop
+
: infer-compose ( -- ) [ <composed> ] \ compose infer-builder ;
+\ compose [ infer-compose ] "special" set-word-prop
+
: infer-execute ( -- )
pop-literal nip
dup word? [
"execute must be given a word" time-bomb
] if ;
+\ execute [ infer-execute ] "special" set-word-prop
+
+\ (execute) [ infer-execute ] "special" set-word-prop
+
: infer-<tuple-boa> ( -- )
\ <tuple-boa>
peek-d literal value>> second 1+ { tuple } <effect>
apply-word/effect ;
+\ <tuple-boa> [ infer-<tuple-boa> ] "special" set-word-prop
+
: infer-effect-unsafe ( word -- )
pop-literal nip
add-effect-input
: infer-execute-effect-unsafe ( -- )
\ (execute) infer-effect-unsafe ;
+\ execute-effect-unsafe [ infer-execute-effect-unsafe ] "special" set-word-prop
+
: infer-call-effect-unsafe ( -- )
\ call infer-effect-unsafe ;
+\ call-effect-unsafe [ infer-call-effect-unsafe ] "special" set-word-prop
+
: infer-exit ( -- )
\ exit (( n -- * )) apply-word/effect ;
+\ exit [ infer-exit ] "special" set-word-prop
+
: infer-load-locals ( -- )
pop-literal nip
consume-d dup copy-values dup output-r
[ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
+\ load-locals [ infer-load-locals ] "special" set-word-prop
+
+: infer-load-local ( -- )
+ 1 infer->r ;
+
+\ load-local [ infer-load-local ] "special" set-word-prop
+
: infer-get-local ( -- )
[let* | n [ pop-literal nip 1 swap - ]
in-r [ n consume-r ]
#shuffle,
] ;
+\ get-local [ infer-get-local ] "special" set-word-prop
+
: infer-drop-locals ( -- )
f f pop-literal nip consume-r f f #shuffle, ;
+\ drop-locals [ infer-drop-locals ] "special" set-word-prop
+
+: infer-call-effect ( word -- )
+ 1 ensure-d first literal value>>
+ add-effect-input add-effect-input
+ apply-word/effect ;
+
+{ call-effect execute-effect } [
+ dup t "no-compile" set-word-prop
+ dup '[ _ infer-call-effect ] "special" set-word-prop
+] each
+
+\ do-primitive [ unknown-primitive-error ] "special" set-word-prop
+
+\ if [ infer-if ] "special" set-word-prop
+\ dispatch [ infer-dispatch ] "special" set-word-prop
+
+\ alien-invoke [ infer-alien-invoke ] "special" set-word-prop
+\ alien-indirect [ infer-alien-indirect ] "special" set-word-prop
+\ alien-callback [ infer-alien-callback ] "special" set-word-prop
+
: infer-special ( word -- )
- {
- { \ declare [ infer-declare ] }
- { \ call [ infer-call ] }
- { \ (call) [ infer-call ] }
- { \ dip [ infer-dip ] }
- { \ 2dip [ infer-2dip ] }
- { \ 3dip [ infer-3dip ] }
- { \ curry [ infer-curry ] }
- { \ compose [ infer-compose ] }
- { \ execute [ infer-execute ] }
- { \ (execute) [ infer-execute ] }
- { \ execute-effect-unsafe [ infer-execute-effect-unsafe ] }
- { \ call-effect-unsafe [ infer-call-effect-unsafe ] }
- { \ if [ infer-if ] }
- { \ dispatch [ infer-dispatch ] }
- { \ <tuple-boa> [ infer-<tuple-boa> ] }
- { \ exit [ infer-exit ] }
- { \ load-local [ 1 infer->r ] }
- { \ load-locals [ infer-load-locals ] }
- { \ get-local [ infer-get-local ] }
- { \ drop-locals [ infer-drop-locals ] }
- { \ do-primitive [ unknown-primitive-error ] }
- { \ alien-invoke [ infer-alien-invoke ] }
- { \ alien-indirect [ infer-alien-indirect ] }
- { \ alien-callback [ infer-alien-callback ] }
- } case ;
+ "special" word-prop call( -- ) ;
: infer-local-reader ( word -- )
(( -- value )) apply-word/effect ;
dispatch <tuple-boa> exit load-local load-locals get-local
drop-locals do-primitive alien-invoke alien-indirect
alien-callback
-} [
- [ t "special" set-word-prop ]
- [ t "no-compile" set-word-prop ] bi
-] each
+} [ t "no-compile" set-word-prop ] each
! Exceptions to the above
\ curry f "no-compile" set-word-prop
\ reset-inline-cache-stats { } { } define-primitive
\ inline-cache-stats { } { array } define-primitive
-\ optimized? { word } { object } define-primitive
\ No newline at end of file
+\ optimized? { word } { object } define-primitive
! Found during code review
[ [ [ drop [ ] ] when call ] infer ] must-fail
-[ swap [ [ drop [ ] ] when call ] infer ] must-fail
\ No newline at end of file
+[ swap [ [ drop [ ] ] when call ] infer ] must-fail
+
+{ 3 1 } [ call( a b -- c ) ] must-infer-as
+{ 3 1 } [ execute( a b -- c ) ] must-infer-as
+
+[ [ call-effect ] infer ] must-fail
+[ [ execute-effect ] infer ] must-fail
: infer. ( quot -- )
#! Safe to call from inference transforms.
infer effect>string print ;
-
-"stack-checker.call-effect" require
\ No newline at end of file
\ spread t "no-compile" set-word-prop
+\ 0&& [ '[ _ 0 n&& ] ] 1 define-transform
+
+\ 0&& t "no-compile" set-word-prop
+
+\ 1&& [ '[ _ 1 n&& ] ] 1 define-transform
+
+\ 1&& t "no-compile" set-word-prop
+
+\ 2&& [ '[ _ 2 n&& ] ] 1 define-transform
+
+\ 2&& t "no-compile" set-word-prop
+
+\ 3&& [ '[ _ 3 n&& ] ] 1 define-transform
+
+\ 3&& t "no-compile" set-word-prop
+
+\ 0|| [ '[ _ 0 n|| ] ] 1 define-transform
+
+\ 0|| t "no-compile" set-word-prop
+
+\ 1|| [ '[ _ 1 n|| ] ] 1 define-transform
+
+\ 1|| t "no-compile" set-word-prop
+
+\ 2|| [ '[ _ 2 n|| ] ] 1 define-transform
+
+\ 2|| t "no-compile" set-word-prop
+
+\ 3|| [ '[ _ 3 n|| ] ] 1 define-transform
+
+\ 3|| t "no-compile" set-word-prop
+
\ (call-next-method) [
[
[ "method-class" word-prop ]
] 1 define-transform
\ boa t "no-compile" set-word-prop
-
-\ new [
- dup tuple-class? [
- dup inlined-dependency depends-on
- [ all-slots [ initial>> literalize ] map ]
- [ tuple-layout '[ _ <tuple-boa> ] ]
- bi append
- ] [ drop f ] if
-] 1 define-transform
-
-! Fast at for integer maps
-CONSTANT: lookup-table-at-max 256
-
-: lookup-table-at? ( assoc -- ? )
- #! Can we use a fast byte array test here?
- {
- [ assoc-size 4 > ]
- [ values [ ] all? ]
- [ keys [ integer? ] all? ]
- [ keys [ 0 lookup-table-at-max between? ] all? ]
- } 1&& ;
-
-: lookup-table-seq ( assoc -- table )
- [ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
-
-: lookup-table-quot ( seq -- newquot )
- lookup-table-seq
- '[
- _ over integer? [
- 2dup bounds-check? [
- nth-unsafe dup >boolean
- ] [ 2drop f f ] if
- ] [ 2drop f f ] if
- ] ;
-
-: fast-lookup-table-at? ( assoc -- ? )
- values {
- [ [ integer? ] all? ]
- [ [ 0 254 between? ] all? ]
- } 1&& ;
-
-: fast-lookup-table-seq ( assoc -- table )
- lookup-table-seq [ 255 or ] B{ } map-as ;
-
-: fast-lookup-table-quot ( seq -- newquot )
- fast-lookup-table-seq
- '[
- _ over integer? [
- 2dup bounds-check? [
- nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
- ] [ 2drop f f ] if
- ] [ 2drop f f ] if
- ] ;
-
-: at-quot ( assoc -- quot )
- dup lookup-table-at? [
- dup fast-lookup-table-at? [
- fast-lookup-table-quot
- ] [
- lookup-table-quot
- ] if
- ] [ drop f ] if ;
-
-\ at* [ at-quot ] 1 define-transform
-
-! Membership testing
-: member-quot ( seq -- newquot )
- dup length 4 <= [
- [ drop f ] swap
- [ literalize [ t ] ] { } map>assoc linear-case-quot
- ] [
- unique [ key? ] curry
- ] if ;
-
-\ member? [
- dup sequence? [ member-quot ] [ drop f ] if
-] 1 define-transform
-
-: memq-quot ( seq -- newquot )
- [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
- [ drop f ] suffix [ cond ] curry ;
-
-\ memq? [
- dup sequence? [ memq-quot ] [ drop f ] if
-] 1 define-transform
-
-! Index search
-\ index [
- dup sequence? [
- dup length 4 >= [
- dup length zip >hashtable '[ _ at ]
- ] [ drop f ] if
- ] [ drop f ] if
-] 1 define-transform
-
-! Shuffling
-: nths-quot ( indices -- quot )
- [ [ '[ _ swap nth ] ] map ] [ length ] bi
- '[ _ cleave _ narray ] ;
-
-\ shuffle [
- shuffle-mapping nths-quot
-] 1 define-transform
IN: struct-arrays.tests
USING: struct-arrays tools.test kernel math sequences
-alien.syntax alien.c-types destructors libc accessors ;
+alien.syntax alien.c-types destructors libc accessors sequences.private ;
C-STRUCT: test-struct
{ "int" "x" }
10 "test-struct" malloc-struct-array
&free drop
] with-destructors
-] unit-test
\ No newline at end of file
+] unit-test
+
+[ 15 ] [ 15 10 "test-struct" <struct-array> resize length ] unit-test
\ No newline at end of file
{ element-size array-capacity read-only } ;
M: struct-array length length>> ;
+M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ;
M: struct-array nth-unsafe
[ element-size>> * ] [ underlying>> ] bi <displaced-alien> ;
M: struct-array new-sequence
element-size>> [ * <byte-array> ] 2keep struct-array boa ; inline
+M: struct-array resize ( n seq -- newseq )
+ [ [ element-size>> * ] [ underlying>> ] bi resize ] [ element-size>> ] 2bi
+ struct-array boa ;
+
: <struct-array> ( length c-type -- struct-array )
heap-size [ * <byte-array> ] 2keep struct-array boa ; inline
--- /dev/null
+IN: struct-vectors
+USING: help.markup help.syntax alien strings math ;
+
+HELP: struct-vector
+{ $class-description "The class of growable C struct and union arrays." } ;
+
+HELP: <struct-vector>
+{ $values { "capacity" integer } { "c-type" string } { "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 alien.syntax
+namespaces kernel sequences ;
+
+C-STRUCT: point
+ { "float" "x" }
+ { "float" "y" } ;
+
+: make-point ( x y -- point )
+ "point" <c-object>
+ [ set-point-y ] keep
+ [ set-point-x ] keep ;
+
+[ ] [ 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 [ point-x ] [ point-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 c-type -- 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
--- /dev/null
+
+: spill-integer-base ( -- n )
+ stack-frame get spill-counts>> double-float-regs swap at
+ double-float-regs reg-size * ;
+
+: spill-integer@ ( n -- offset )
+ cells spill-integer-base + param@ ;
+
+: spill-float@ ( n -- offset )
+ double-float-regs reg-size * param@ ;
+
+: (stack-frame-size) ( stack-frame -- n )
+ [
+ {
+ [ spill-counts>> [ swap reg-size * ] { } assoc>map sum ]
+ [ gc-roots>> cells ]
+ [ params>> ]
+ [ return>> ]
+ } cleave
+ ] sum-outputs ;
\ No newline at end of file
: thread-registered? ( thread -- ? )
id>> threads key? ;
+ERROR: already-stopped thread ;
+
: check-unregistered ( thread -- thread )
- dup thread-registered?
- [ "Thread already stopped" throw ] when ;
+ dup thread-registered? [ already-stopped ] when ;
+
+ERROR: not-running thread ;
: check-registered ( thread -- thread )
- dup thread-registered?
- [ "Thread is not running" throw ] unless ;
+ dup thread-registered? [ not-running ] unless ;
<PRIVATE
ABOUT: "tools.annotations"
HELP: annotate
-{ $values { "word" "a word" } { "quot" { $quotation "( word def -- def )" } } }
+{ $values { "word" "a word" } { "quot" { $quotation "( old-def -- new-def )" } } }
{ $description "Changes a word definition to the result of applying a quotation to the old definition." }
{ $notes "This word is used to implement " { $link watch } "." } ;
[ ] [ M\ string blah-generic watch ] unit-test
[ "hi" ] [ "hi" blah-generic ] unit-test
+
+! See how well watch interacts with optimizations.
+GENERIC: my-generic ( a -- b )
+M: object my-generic ;
+
+\ my-generic watch
+
+: some-code ( -- )
+ f my-generic drop ;
+
+[ ] [ some-code ] unit-test
\ No newline at end of file
USING: accessors kernel math sorting words parser io summary
quotations sequences prettyprint continuations effects
definitions compiler.units namespaces assocs tools.walker
-tools.time generic inspector fry tools.continuations ;
+tools.time generic inspector fry tools.continuations
+locals generalizations macros ;
IN: tools.annotations
-GENERIC: reset ( word -- )
+<PRIVATE
+
+GENERIC: (reset) ( word -- )
-M: generic reset
- subwords [ reset ] each ;
+M: generic (reset)
+ subwords [ (reset) ] each ;
-M: word reset
+M: word (reset)
dup "unannotated-def" word-prop [
- [
- dup dup "unannotated-def" word-prop define
- ] with-compilation-unit
+ dup dup "unannotated-def" word-prop define
f "unannotated-def" set-word-prop
] [ drop ] if ;
+PRIVATE>
+
+: reset ( word -- )
+ [ (reset) ] with-compilation-unit ;
+
ERROR: cannot-annotate-twice word ;
M: cannot-annotate-twice summary drop "Cannot annotate a word twice" ;
cannot-annotate-twice
] when ;
-PRIVATE>
-
-GENERIC# annotate 1 ( word quot -- )
+GENERIC# (annotate) 1 ( word quot -- )
-M: generic annotate
- [ "methods" word-prop values ] dip '[ _ annotate ] each ;
+M: generic (annotate)
+ [ "methods" word-prop values ] dip '[ _ (annotate) ] each ;
-M: word annotate
+M: word (annotate)
[ check-annotate-twice ] dip
- [
- [ dup def>> 2dup "unannotated-def" set-word-prop ] dip
- call( old -- new ) define
- ] with-compilation-unit ;
+ [ dup def>> 2dup "unannotated-def" set-word-prop ] dip
+ call( old -- new ) define ;
-<PRIVATE
+PRIVATE>
-: stack-values ( names -- alist )
- [ datastack ] dip [ nip ] [ length tail* ] 2bi zip ;
+: annotate ( word quot -- )
+ [ (annotate) ] with-compilation-unit ;
-: trace-message ( word quot str -- )
- "--- " write write bl over .
- [ stack-effect ] dip '[ @ stack-values ] [ f ] if*
- [ simple-table. ] unless-empty flush ; inline
+<PRIVATE
+
+:: trace-quot ( word effect quot str -- quot' )
+ effect quot call :> values
+ values length :> n
+ [
+ "--- " write str write bl word .
+ n ndup n narray values swap zip simple-table.
+ flush
+ ] ; inline
-: entering ( str -- ) [ in>> ] "Entering" trace-message ;
+MACRO: entering ( word -- quot )
+ dup stack-effect [ in>> ] "Entering" trace-quot ;
-: leaving ( str -- ) [ out>> ] "Leaving" trace-message ;
+MACRO: leaving ( word -- quot )
+ dup stack-effect [ out>> ] "Leaving" trace-quot ;
: (watch) ( word def -- def )
over '[ _ entering @ _ leaving ] ;
all-words name-completions ;
: vocabs-matching ( str -- seq )
- all-vocabs-seq name-completions ;
+ all-vocabs-recursive no-roots no-prefixes name-completions ;
: chars-matching ( str -- seq )
name-map keys dup zip completions ;
[ nip require ]
} 2cleave ;
+: scaffold-core ( string -- ) "resource:core" swap scaffold-vocab ;
+
+: scaffold-basis ( string -- ) "resource:basis" swap scaffold-vocab ;
+
+: scaffold-extra ( string -- ) "resource:extra" swap scaffold-vocab ;
+
+: scaffold-work ( string -- ) "resource:work" swap scaffold-vocab ;
+
<PRIVATE
: tests-file-string ( vocab -- string )
HOOK: offscreen-pixels ui-backend ( world -- alien w h )
-: with-gl-context ( handle quot -- )
- '[ select-gl-context @ ]
- [ flush-gl-context gl-error ] bi ; inline
-
HOOK: (with-ui) ui-backend ( quot -- )
HOOK: (grab-input) ui-backend ( handle -- )
] [ drop ] if ;
: end-selection ( pane -- )
- f >>selecting?
- hand-moved?
+ dup selecting?>> hand-moved? or
+ [ f >>selecting? ] dip
[ [ com-copy-selection ] [ request-focus ] bi ]
[ [ relayout-1 ] [ focus-input ] bi ]
if ;
if ;
: row-action? ( table -- ? )
- [ [ mouse-row ] keep valid-line? ]
- [ single-click?>> hand-click# get 2 = or ] bi and ;
+ single-click?>> hand-click# get 2 = or ;
<PRIVATE
: table-button-up ( table -- )
- dup row-action? [ row-action ] [ update-selected-values ] if ;
+ dup [ mouse-row ] keep valid-line? [
+ dup row-action? [ row-action ] [ update-selected-values ] if
+ ] [ drop ] if ;
PRIVATE>
USING: ui.gadgets ui.render ui.text ui.text.private
ui.gestures ui.backend help.markup help.syntax
-models opengl sequences strings ;
+models opengl sequences strings destructors ;
IN: ui.gadgets.worlds
HELP: user-input
{ $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" } "." } ;
-HELP: select-gl-context
-{ $values { "handle" "a backend-specific handle" } }
+HELP: set-gl-context
+{ $values { "world" world } }
{ $description "Selects an OpenGL context to be the implicit destination for subsequent GL rendering calls. This word is called automatically by the UI before drawing a " { $link world } "." } ;
+HELP: window-resource
+{ $values { "resource" disposable } { "resource" disposable } }
+{ $description "Marks " { $snippet "resource" } " to be destroyed with " { $link dispose } " when the window with the currently active OpenGL context (set by " { $link set-gl-context } ") is closed. " { $snippet "resource" } " is left unmodified at the top of the stack." } ;
+
HELP: flush-gl-context
{ $values { "handle" "a backend-specific handle" } }
{ $description "Ensures all GL rendering calls made to an OpenGL context finish rendering to the screen. This word is called automatically by the UI after drawing a " { $link world } "." } ;
text-handle handle images
window-loc
pixel-format-attributes
- window-controls ;
+ window-controls
+ window-resources ;
TUPLE: world-attributes
{ world-class initial: world }
'[ f _ [ (>>status-owner) ] [ status>> set-model ] 2bi ] when
] [ 2drop ] if ;
+: window-resource ( resource -- resource )
+ dup world get-global window-resources>> push ;
+
+: set-gl-context ( world -- )
+ [ world set-global ]
+ [ handle>> select-gl-context ] bi ;
+
+: with-gl-context ( world quot -- )
+ '[ set-gl-context @ ]
+ [ handle>> flush-gl-context gl-error ] bi ; inline
+
ERROR: no-world-found ;
: find-gl-context ( gadget -- )
find-world dup
- [ handle>> select-gl-context ] [ no-world-found ] if ;
+ [ set-gl-context ] [ no-world-found ] if ;
: (request-focus) ( child world ? -- )
pick parent>> pick eq? [
t >>root?
f >>active?
{ 0 0 } >>window-loc
- f >>grab-input? ;
+ f >>grab-input?
+ V{ } clone >>window-resources ;
: apply-world-attributes ( world attributes -- world )
{
M: world (>>dim)
[ call-next-method ]
[
- dup handle>>
- [ select-gl-context resize-world ]
- [ drop ] if*
+ dup active?>> [
+ dup handle>>
+ [ [ set-gl-context ] [ resize-world ] bi ]
+ [ drop ] if
+ ] [ drop ] if
] bi ;
GENERIC: draw-world* ( world -- )
dup draw-world? [
dup world [
[
- dup handle>> [ draw-world* ] with-gl-context
+ dup [ draw-world* ] with-gl-context
flush-layout-cache-hook get call( -- )
] [
over <world-error> ui-error
M: word-completion row-color
[ vocabulary>> ] [ manifest>> ] bi* {
+ { [ dup not ] [ COLOR: black ] }
{ [ 2dup search-vocabs>> memq? ] [ COLOR: black ] }
{ [ over ".private" tail? ] [ COLOR: dark-red ] }
[ COLOR: dark-gray ]
[ ] [ "h" get history-recall-previous ] unit-test
[ "22" ] [ "d" get doc-string ] unit-test
+
+[ ] [ <document> "d" set ] unit-test
+[ ] [ "d" get <history> "h" set ] unit-test
+
+[ ] [ "aaa" "d" get set-doc-string ] unit-test
+[ T{ input f "aaa" } ] [ "h" get history-add ] unit-test
+
+[ ] [ "" "d" get set-doc-string ] unit-test
+[ T{ input f "" } ] [ "h" get history-add ] unit-test
+[ T{ input f "" } ] [ "h" get history-add ] unit-test
+[ ] [ " " "d" get set-doc-string ] unit-test
+[ ] [ "h" get history-recall-previous ] unit-test
+
<PRIVATE
+: (save-history) ( input index elements -- )
+ 2dup length > [
+ [ [ T{ input f "" } ] dip push ] keep
+ (save-history)
+ ] [ set-nth ] if ;
+
: save-history ( history -- )
[ document>> doc-string ] keep
- '[ <input> _ [ index>> ] [ elements>> ] bi set-nth ]
+ '[ <input> _ [ index>> ] [ elements>> ] bi (save-history) ]
unless-empty ;
: update-document ( history -- )
: use-if-necessary ( word manifest -- )
2dup [ vocabulary>> ] dip and [
manifest [
- vocabulary>> use-vocab
+ [ vocabulary>> use-vocab ]
+ [ dup name>> associate use-words ] bi
] with-variable
] [ 2drop ] if ;
} define-command-map
tool "common" f {
- { T{ key-down f { A+ } "s" } save }
{ T{ key-down f { A+ } "w" } close-window }
{ T{ key-down f { A+ } "q" } com-exit }
{ T{ key-down f f "F2" } refresh-all }
: set-up-window ( world -- )
{
- [ handle>> select-gl-context ]
+ [ set-gl-context ]
[ [ title>> ] keep set-title ]
[ begin-world ]
[ resize-world ]
: (ungraft-world) ( world -- )
{
- [ handle>> select-gl-context ]
+ [ set-gl-context ]
[ text-handle>> [ dispose ] when* ]
[ images>> [ dispose ] when* ]
[ hand-clicked close-global ]
[ hand-gadget close-global ]
[ end-world ]
+ [ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
} cleave ;
M: world ungraft*
"The " { $vocab-link "unicode.breaks" "unicode.breaks" } " vocabulary partially implements Unicode Standard Annex #29. This provides for segmentation of a string along grapheme and word boundaries. In Unicode, a grapheme, or a basic unit of display in text, may be more than one code point. For example, in the string \"e\\u000301\" (where U+0301 is a combining acute accent), there is only one grapheme, as the acute accent goes above the e, forming a single grapheme. Word breaks, in general, are more complicated than simply splitting by whitespace, and the Unicode algorithm provides for that."
$nl "Operations for graphemes:"
{ $subsection first-grapheme }
+{ $subsection first-grapheme-from }
{ $subsection last-grapheme }
+{ $subsection last-grapheme-from }
{ $subsection >graphemes }
{ $subsection string-reverse }
"Operations on words:"
{ $subsection first-word }
+{ $subsection first-word-from }
+{ $subsection last-word }
+{ $subsection last-word-from }
{ $subsection >words } ;
HELP: first-grapheme
{ $values { "str" string } { "i" "an index" } }
{ $description "Finds the index of the start of the last grapheme of the string. This can be used to traverse the graphemes of a string backwards." } ;
+HELP: first-grapheme-from
+{ $values { "start" "an index" } { "str" string } { "i" "an index" } }
+{ $description "Finds the length of the first grapheme of the string, starting from the given index. This can be used repeatedly to efficiently traverse the graphemes of the string, using slices." } ;
+
+HELP: last-grapheme-from
+{ $values { "end" "an index" } { "str" string } { "i" "an index" } }
+{ $description "Finds the index of the start of the last grapheme of the string, starting from the given index. This can be used to traverse the graphemes of a string backwards." } ;
+
HELP: >graphemes
{ $values { "str" string } { "graphemes" "an array of strings" } }
{ $description "Divides a string into a sequence of individual graphemes." } ;
HELP: first-word
{ $values { "str" string } { "i" "index" } }
-{ $description "Finds the length of the first word in the string." } ;
+{ $description "Finds the index of the end of the first word in the string." } ;
+
+HELP: last-word
+{ $values { "str" string } { "i" "index" } }
+{ $description "Finds the index of the beginning of the last word in the string." } ;
+
+HELP: first-word-from
+{ $values { "start" "index" } { "str" string } { "i" "index" } }
+{ $description "Finds the index of the end of the first word in the string, starting from the given index." } ;
+
+HELP: last-word-from
+{ $values { "end" "index" } { "str" string } { "i" "index" } }
+{ $description "Finds the index of the start of the word that the index is contained in." } ;
HELP: >words
{ $values { "str" string } { "words" "an array of strings" } }
[ 3 ] [ 2 "hello" first-grapheme-from ] unit-test
[ 1 ] [ 2 "hello" last-grapheme-from ] unit-test
+[ 4 ] [ 2 "what am I saying" first-word-from ] unit-test
+[ 0 ] [ 2 "what am I saying" last-word-from ] unit-test
+[ 16 ] [ 11 "what am I saying" first-word-from ] unit-test
+[ 10 ] [ 11 "what am I saying" last-word-from ] unit-test
+
: grapheme-break-test ( -- filename )
"vocab:unicode/breaks/GraphemeBreakTest.txt" ;
word-break-next nip
]
} 2|| ;
+
+: first-word-from ( start str -- i )
+ over tail-slice first-word + ;
+
+: last-word ( str -- i )
+ [ length ] keep '[ _ word-break-at? ] find-last drop 0 or ;
+
+: last-word-from ( end str -- i )
+ swap head-slice last-word ;
"USING: io urls.encoding ;"
"{ { \"from\" \"Lead\" } { \"to\" \"Gold, please\" } }"
"assoc>query print"
- "from=Lead&to=Gold%2c%20please"
+ "from=Lead&to=Gold%2C%20please"
}
} ;
: push-utf8 ( ch -- )
1string utf8 encode
- [ CHAR: % , >hex 2 CHAR: 0 pad-head % ] each ;
+ [ CHAR: % , >hex >upper 2 CHAR: 0 pad-head % ] each ;
PRIVATE>
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: functors sequences sequences.private growable
+kernel words classes math parser ;
+IN: vectors.functor
+
+FUNCTOR: define-vector ( V A <A> -- )
+
+<V> DEFINES <${V}>
+>V DEFINES >${V}
+
+WHERE
+
+TUPLE: V { underlying A } { length array-capacity } ;
+
+: <V> ( capacity -- vector ) <A> 0 V boa ; inline
+
+M: V like
+ drop dup V instance? [
+ dup A instance? [ dup length V boa ] [ >V ] if
+ ] unless ;
+
+M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
+
+M: A new-resizable drop <V> ;
+
+M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
+
+: >V ( seq -- vector ) V new clone-like ; inline
+
+INSTANCE: V growable
+
+;FUNCTOR
: reset-cache ( -- )
root-cache get-global clear-assoc
\ vocab-file-contents reset-memoized
- \ all-vocabs-seq reset-memoized
+ \ all-vocabs-recursive reset-memoized
\ all-authors reset-memoized
\ all-tags reset-memoized ;
"Loading vocabulary hierarchies:"\r
{ $subsection load }\r
{ $subsection load-all }\r
-"Getting all vocabularies on disk:"\r
+"Getting all vocabularies from disk:"\r
{ $subsection all-vocabs }\r
-{ $subsection all-vocabs-seq }\r
-"Getting " { $link "vocabs.metadata" } " for all vocabularies on disk:"\r
+{ $subsection all-vocabs-recursive }\r
+"Getting all vocabularies from disk whose names which match a string prefix:"\r
+{ $subsection child-vocabs }\r
+{ $subsection child-vocabs-recursive }\r
+"Words for modifying output:"\r
+{ $subsection no-roots }\r
+{ $subsection no-prefixes }\r
+"Getting " { $link "vocabs.metadata" } " for all vocabularies from disk:"\r
{ $subsection all-tags }\r
{ $subsection all-authors } ;\r
\r
ABOUT: "vocabs.hierarchy"\r
\r
-HELP: all-vocabs\r
-{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }\r
-{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;\r
-\r
HELP: load\r
{ $values { "prefix" string } }\r
{ $description "Load all vocabularies that match the provided prefix." }\r
HELP: load-all\r
{ $description "Load all vocabularies in the source tree." } ;\r
\r
-HELP: all-vocabs-under\r
-{ $values { "prefix" string } { "vocabs" "a sequence of vocabularies" } }\r
-{ $description "Return a sequence of vocab or vocab-links for each vocab matching the provided prefix. Unlike " { $link all-child-vocabs } " this word will return both loaded and unloaded vocabularies." } ;\r
! Copyright (C) 2007, 2009 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: arrays assocs combinators.short-circuit fry\r
+USING: accessors arrays assocs combinators.short-circuit fry\r
io.directories io.files io.files.info io.pathnames kernel make\r
memoize namespaces sequences sorting splitting vocabs sets\r
vocabs.loader vocabs.metadata vocabs.errors ;\r
+RENAME: child-vocabs vocabs => vocabs:child-vocabs\r
IN: vocabs.hierarchy\r
\r
+TUPLE: vocab-prefix name ;\r
+\r
+C: <vocab-prefix> vocab-prefix\r
+\r
+M: vocab-prefix vocab-name name>> ;\r
+\r
<PRIVATE\r
\r
: vocab-subdirs ( dir -- dirs )\r
] filter\r
] with-directory-files natural-sort ;\r
\r
-: (all-child-vocabs) ( root name -- vocabs )\r
- [\r
- vocab-dir append-path dup exists?\r
- [ vocab-subdirs ] [ drop { } ] if\r
- ] keep\r
- [ '[ [ _ "." ] dip 3append ] map ] unless-empty ;\r
-\r
: vocab-dir? ( root name -- ? )\r
over\r
[ ".factor" vocab-dir+ append-path exists? ]\r
[ 2drop f ]\r
if ;\r
\r
-: vocabs-in-dir ( root name -- )\r
- dupd (all-child-vocabs) [\r
- 2dup vocab-dir? [ dup >vocab-link , ] when\r
- vocabs-in-dir\r
- ] with each ;\r
+: (child-vocabs) ( root prefix -- vocabs )\r
+ [ vocab-dir append-path dup exists? [ vocab-subdirs ] [ drop { } ] if ]\r
+ [ nip [ '[ [ _ "." ] dip 3append ] map ] unless-empty ]\r
+ [ drop '[ _ over vocab-dir? [ >vocab-link ] [ <vocab-prefix> ] if ] map ]\r
+ 2tri ;\r
\r
-PRIVATE>\r
+: ((child-vocabs-recursive)) ( root name -- )\r
+ dupd vocab-name (child-vocabs)\r
+ [ dup , ((child-vocabs-recursive)) ] with each ;\r
\r
-: all-vocabs ( -- assoc )\r
- vocab-roots get [\r
- dup [ "" vocabs-in-dir ] { } make\r
- ] { } map>assoc ;\r
-\r
-: all-vocabs-under ( prefix -- vocabs )\r
- [\r
- [ vocab-roots get ] dip '[ _ vocabs-in-dir ] each\r
- ] { } make ;\r
+: (child-vocabs-recursive) ( root name -- seq )\r
+ [ ((child-vocabs-recursive)) ] { } make ;\r
\r
-MEMO: all-vocabs-seq ( -- seq )\r
- "" all-vocabs-under ;\r
+: no-rooted ( seq -- seq' ) [ find-vocab-root not ] filter ;\r
\r
-<PRIVATE\r
+: one-level-only? ( name prefix -- ? )\r
+ ?head [ "." split1 nip not ] dip and ;\r
\r
: unrooted-child-vocabs ( prefix -- seq )\r
+ [ vocabs no-rooted ] dip\r
dup empty? [ CHAR: . suffix ] unless\r
- vocabs\r
- [ find-vocab-root not ] filter\r
- [\r
- vocab-name swap ?head CHAR: . rot member? not and\r
- ] with filter\r
- [ vocab ] map ;\r
+ '[ vocab-name _ one-level-only? ] filter ;\r
+\r
+: unrooted-child-vocabs-recursive ( prefix -- seq )\r
+ vocabs:child-vocabs no-rooted ;\r
\r
PRIVATE>\r
\r
-: all-child-vocabs ( prefix -- assoc )\r
- vocab-roots get [\r
- dup pick (all-child-vocabs) [ >vocab-link ] map\r
- ] { } map>assoc\r
- swap unrooted-child-vocabs f swap 2array suffix ;\r
+: no-prefixes ( seq -- seq' ) [ vocab-prefix? not ] filter ;\r
\r
-: all-child-vocabs-seq ( prefix -- assoc )\r
- vocab-roots get swap '[\r
- dup _ (all-child-vocabs)\r
- [ vocab-dir? ] with filter\r
- ] map concat ;\r
+: convert-prefixes ( seq -- seq' )\r
+ [ dup vocab-prefix? [ name>> vocab-link boa ] when ] map ;\r
+\r
+: remove-redundant-prefixes ( seq -- seq' )\r
+ #! Hack.\r
+ [ vocab-prefix? ] partition\r
+ [\r
+ [ vocab-name ] map unique\r
+ '[ name>> _ key? not ] filter\r
+ convert-prefixes\r
+ ] keep\r
+ append ;\r
+\r
+: no-roots ( assoc -- seq ) values concat ;\r
+\r
+: child-vocabs ( prefix -- assoc )\r
+ [ [ vocab-roots get ] dip '[ dup _ (child-vocabs) ] { } map>assoc ]\r
+ [ unrooted-child-vocabs [ vocab ] map f swap 2array ]\r
+ bi suffix ;\r
+\r
+: all-vocabs ( -- assoc )\r
+ "" child-vocabs ;\r
+\r
+: child-vocabs-recursive ( prefix -- assoc )\r
+ [ [ vocab-roots get ] dip '[ dup _ (child-vocabs-recursive) ] { } map>assoc ]\r
+ [ unrooted-child-vocabs-recursive [ vocab ] map f swap 2array ]\r
+ bi suffix ;\r
+\r
+MEMO: all-vocabs-recursive ( -- assoc )\r
+ "" child-vocabs-recursive ;\r
+\r
+: all-vocab-names ( -- seq )\r
+ all-vocabs-recursive no-roots no-prefixes [ vocab-name ] map ;\r
+\r
+: child-vocab-names ( prefix -- seq )\r
+ child-vocabs no-roots no-prefixes [ vocab-name ] map ;\r
\r
<PRIVATE\r
\r
: filter-unportable ( seq -- seq' )\r
[ vocab-name unportable? not ] filter ;\r
\r
+: collect-vocabs ( quot -- seq )\r
+ [ all-vocabs-recursive no-roots no-prefixes ] dip\r
+ gather natural-sort ; inline\r
+\r
PRIVATE>\r
\r
: (load) ( prefix -- failures )\r
- all-vocabs-under\r
+ child-vocabs-recursive no-roots no-prefixes\r
filter-unportable\r
require-all ;\r
\r
: load-all ( -- )\r
"" load ;\r
\r
-MEMO: all-tags ( -- seq )\r
- all-vocabs-seq [ vocab-tags ] gather natural-sort ;\r
+MEMO: all-tags ( -- seq ) [ vocab-tags ] collect-vocabs ;\r
\r
-MEMO: all-authors ( -- seq )\r
- all-vocabs-seq [ vocab-authors ] gather natural-sort ;
\ No newline at end of file
+MEMO: all-authors ( -- seq ) [ vocab-authors ] collect-vocabs ;\r
[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test
[ "a b c d e f\ng h" ] [ "a b c d e f g h" 11 wrap-string ] unit-test
+
+[ "" ] [ "" 10 wrap-string ] unit-test
+[ "Hello" ] [ "\nHello\n" 10 wrap-string ] unit-test
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: wrap tools.test ;
+
+[ { } ] [ { } 10 10 wrap ] unit-test
[
line-ideal set
line-max set
- initialize
- [ wrap-step ] reduce
- min-cost
- post-process
+ [ { } ] [
+ initialize
+ [ wrap-step ] reduce
+ min-cost
+ post-process
+ ] if-empty
] with-scope ;
[ "( displaced alien )" ] [ 0 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
-[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
-
-[ f ] [ "does not exist" DLL" fadsfasfdsaf" dlsym ] unit-test
-
SYMBOL: initialize-test
f initialize-test set-global
[ f ] [ 1 2 H{ { 2 1 } } maybe-set-at ] unit-test
[ t ] [ 1 3 H{ { 2 1 } } clone maybe-set-at ] unit-test
[ t ] [ 3 2 H{ { 2 1 } } clone maybe-set-at ] unit-test
+
+[ H{ { 1 2 } { 2 3 } } ] [
+ {
+ H{ { 1 3 } }
+ H{ { 2 3 } }
+ H{ { 1 2 } }
+ } assoc-combine
+] unit-test
+
+[ H{ { 1 7 } } ] [
+ {
+ H{ { 1 2 } { 2 4 } { 5 6 } }
+ H{ { 1 3 } { 2 5 } }
+ H{ { 1 7 } { 5 6 } }
+ } assoc-refine
+] unit-test
\ No newline at end of file
: assoc-combine ( seq -- union )
H{ } clone [ dupd update ] reduce ;
+: assoc-refine ( seq -- assoc )
+ [ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
+
: assoc-diff ( assoc1 assoc2 -- diff )
[ nip key? not ] curry assoc-filter ;
M: byte-vector equal?\r
over byte-vector? [ sequence= ] [ 2drop f ] if ;\r
\r
+M: byte-vector contract 2drop ;\r
+\r
M: byte-array like\r
#! If we have an byte-array, we're done.\r
#! If we have a byte-vector, and it's at full capacity,\r
PREDICATE: predicate-class < class
"metaclass" word-prop predicate-class eq? ;
-: predicate-quot ( class -- quot )
+GENERIC: predicate-quot ( class -- quot )
+
+M: predicate-class predicate-quot
[
\ dup ,
[ superclass "predicate" word-prop % ]
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008, 2009 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.algebra classes.predicate kernel
sequences words ;
IN: classes.singleton
+: singleton-predicate-quot ( class -- quot ) [ eq? ] curry ;
+
PREDICATE: singleton-class < predicate-class
[ "predicate-definition" word-prop ]
- [ [ eq? ] curry ] bi sequence= ;
+ [ singleton-predicate-quot ]
+ bi sequence= ;
: define-singleton-class ( word -- )
- \ word over [ eq? ] curry define-predicate-class ;
+ \ word over singleton-predicate-quot define-predicate-class ;
M: singleton-class instance? eq? ;
M: singleton-class (classes-intersect?)
over singleton-class? [ eq? ] [ call-next-method ] if ;
+
+M: singleton-class predicate-quot
+ singleton-predicate-quot ;
\ No newline at end of file
: parse-long-slot-name ( -- spec )
[ scan , \ } parse-until % ] { } make ;
-: parse-slot-name ( string/f -- ? )
+: parse-slot-name-delim ( end-delim string/f -- ? )
#! This isn't meant to enforce any kind of policy, just
#! to check for mistakes of this form:
#!
{
{ [ dup not ] [ unexpected-eof ] }
{ [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
- { [ dup ";" = ] [ drop f ] }
+ { [ 2dup = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
- } cond ;
+ } cond nip ;
+
+: parse-tuple-slots-delim ( end-delim -- )
+ dup scan parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
+
+: parse-slot-name ( string/f -- ? )
+ ";" swap parse-slot-name-delim ;
: parse-tuple-slots ( -- )
- scan parse-slot-name [ parse-tuple-slots ] when ;
+ ";" parse-tuple-slots-delim ;
: parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS
M: tuple class layout-of 2 slot { word } declare ;
: tuple-size ( tuple -- size )
- layout-of second ; inline
+ layout-of 3 slot { fixnum } declare ; inline
: prepare-tuple>array ( tuple -- n tuple layout )
check-tuple [ tuple-size ] [ ] [ layout-of ] tri ;
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private
sequences sequences.private ;
: expand ( len seq -- )
[ resize ] change-underlying drop ; inline
-: contract ( len seq -- )
+GENERIC: contract ( len seq -- )
+
+M: growable contract ( len seq -- )
[ length ] keep
[ [ 0 ] 2dip set-nth-unsafe ] curry
- (each-integer) ; inline
+ (each-integer) ;
: growable-check ( n seq -- n seq )
over 0 < [ bounds-error ] when ; inline
[ 1 ] [ "h" get assoc-size ] unit-test
[ 1 ] [ 2 "h" get at ] unit-test
+
+! Random test case
+[ "A" ] [ 100 [ dup ] H{ } map>assoc 32 over delete-at "A" 32 pick set-at 32 swap at ] unit-test
\ No newline at end of file
HELP: all-integers?
{ $values { "n" integer } { "quot" { $quotation "( i -- ? )" } } { "?" "a boolean" } }
-{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iterationi stops when the quotation outputs " { $link f } " or the end is reached. If the quotation yields a false value for some integer, this word outputs " { $link f } ". Otherwise, this word outputs " { $link t } "." }
+{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iteration stops when the quotation outputs " { $link f } " or the end is reached. If the quotation yields a false value for some integer, this word outputs " { $link f } ". Otherwise, this word outputs " { $link t } "." }
{ $notes "This word is used to implement " { $link all? } "." } ;
HELP: find-integer
[ 3 ] [ x ] unit-test
[ 4 ] [ y ] unit-test
-[ "IN: qualified.tests FROM: qualified.tests => doesnotexist ;" eval( -- ) ]
-[ error>> no-word-error? ] must-fail-with
-
-[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval( -- ) ]
-[ error>> no-word-error? ] must-fail-with
-
! Two similar bugs
! Replace : def with something in << >>
{ "newseq" sequence } }
{ $description "Calls the quotation for every element of the sequence in order. However, the element is not passed to the quotation -- it is dropped, and the quotation produces an element of its own that is collected into a sequence of the same class as the input sequence." }
{ $examples
- { $unchecked-example "USING: prettyprint kernel sequences ;"
+ { $unchecked-example "USING: kernel prettyprint random sequences ;"
"5 [ 100 random ] replicate ."
"{ 52 10 45 81 30 }"
}
USE: make
[ { "a" 1 "b" 1 "c" } ]
-[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test
\ No newline at end of file
+[ 1 { "a" "b" "c" } [ [ dup , ] [ , ] interleave drop ] { } make ] unit-test
+
+[ t ] [ 0 array-capacity? ] unit-test
+[ f ] [ -1 array-capacity? ] unit-test
\ No newline at end of file
"Adding elements to sets:"
{ $subsection adjoin }
{ $subsection conjoin }
+{ $subsection conjoin-at }
{ $see-also member? memq? any? all? "assocs-sets" } ;
ABOUT: "sets"
}
{ $side-effects "assoc" } ;
+HELP: conjoin-at
+{ $values { "value" object } { "key" object } { "assoc" assoc } }
+{ $description "Adds " { $snippet "value" } " to the set stored at " { $snippet "key" } " of " { $snippet "assoc" } "." } ;
+
HELP: unique
{ $values { "seq" "a sequence" } { "assoc" assoc } }
{ $description "Outputs a new assoc where the keys and values are equal." }
: conjoin ( elt assoc -- ) dupd set-at ;
+: conjoin-at ( value key assoc -- )
+ [ dupd ?set-at ] change-at ;
+
: (prune) ( elt hash vec -- )
3dup drop key? [ 3drop ] [
[ drop conjoin ] [ nip push ] 3bi
HELP: QUALIFIED:
{ $syntax "QUALIFIED: vocab" }
{ $description "Adds the vocabulary's words, prefixed with the vocabulary name, to the search path." }
-{ $notes "If adding the vocabulary introduces ambiguity, the vocabulary will take precedence when resolving any ambiguous names. This is a rare case; for example, suppose a vocabulary " { $snippet "fish" } " defines a word named " { $snippet "go:fishing" } ", and a vocabulary named " { $snippet "go" } " defines a word named " { $snippet "finishing" } ". Then, the following will call the latter word:"
+{ $notes "If adding the vocabulary introduces ambiguity, the vocabulary will take precedence when resolving any ambiguous names. This is a rare case; for example, suppose a vocabulary " { $snippet "fish" } " defines a word named " { $snippet "go:fishing" } ", and a vocabulary named " { $snippet "go" } " defines a word named " { $snippet "fishing" } ". Then, the following will call the latter word:"
{ $code
"USE: fish"
"QUALIFIED: go"
--- /dev/null
+IN: vocabs.parser.tests
+USING: vocabs.parser tools.test eval kernel accessors ;
+
+[ "FROM: kernel => doesnotexist ;" eval( -- ) ]
+[ error>> T{ no-word-in-vocab { word "doesnotexist" } { vocab "kernel" } } = ]
+must-fail-with
+
+[ "RENAME: doesnotexist kernel => newname" eval( -- ) ]
+[ error>> T{ no-word-in-vocab { word "doesnotexist" } { vocab "kernel" } } = ]
+must-fail-with
\ No newline at end of file
[ qualified-vocabs>> delete-all ]
tri ;
+ERROR: no-word-in-vocab word vocab ;
+
<PRIVATE
: (add-qualified) ( qualified -- )
manifest get qualified-vocabs>> push ;
-: (from) ( vocab words -- vocab words words' assoc )
- 2dup swap load-vocab words>> ;
+: (from) ( vocab words -- vocab words words' vocab )
+ 2dup swap load-vocab ;
-: extract-words ( seq assoc -- assoc' )
- extract-keys dup [ [ drop ] [ no-word-error ] if ] assoc-each ;
+: extract-words ( seq vocab -- assoc' )
+ [ words>> extract-keys dup ] [ name>> ] bi
+ [ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ;
: (lookup) ( name assoc -- word/f )
at dup forward-reference? [ drop f ] when ;
TUPLE: exclude vocab names words ;
: <exclude> ( vocab words -- from )
- (from) [ nip ] [ extract-words ] 2bi assoc-diff exclude boa ;
+ (from) [ nip words>> ] [ extract-words ] 2bi assoc-diff exclude boa ;
: add-words-excluding ( vocab words -- )
<exclude> (add-qualified) ;
TUPLE: rename word vocab words ;
: <rename> ( word vocab new-name -- rename )
- [ 2dup load-vocab words>> dupd at [ ] [ no-word-error ] ?if ] dip
+ [ 2dup load-vocab words>> dupd at [ ] [ swap no-word-in-vocab ] ?if ] dip
associate rename boa ;
: add-renamed-word ( word vocab new-name -- )
--- /dev/null
+Jeremy Hughes
--- /dev/null
+Jeremy Hughes
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel strings words.symbol sequences ;
+IN: alien.inline.compiler
+
+HELP: C
+{ $var-description "A symbol representing C source." } ;
+
+HELP: C++
+{ $var-description "A symbol representing C++ source." } ;
+
+HELP: compile-to-library
+{ $values
+ { "lang" symbol } { "args" sequence } { "contents" string } { "name" string }
+}
+{ $description "Compiles and links " { $snippet "contents" } " into a shared library called " { $snippet "libname.suffix" }
+ "in " { $snippet "resource:alien-inline-libs" } ". " { $snippet "suffix" } " is OS specific. "
+ { $snippet "args" } " is a sequence of arguments for the linking stage." }
+{ $notes
+ { $list
+ "C and C++ are the only supported languages."
+ { "Source and object files are placed in " { $snippet "resource:temp" } "." } }
+} ;
+
+HELP: compiler
+{ $values
+ { "lang" symbol }
+ { "str" string }
+}
+{ $description "Returns a compiler name based on OS and source language." }
+{ $see-also compiler-descr } ;
+
+HELP: compiler-descr
+{ $values
+ { "lang" symbol }
+ { "descr" "a process description" }
+}
+{ $description "Returns a compiler process description based on OS and source language." }
+{ $see-also compiler } ;
+
+HELP: inline-library-file
+{ $values
+ { "name" string }
+ { "path" "a pathname string" }
+}
+{ $description "Appends " { $snippet "name" } " to the " { $link inline-libs-directory } "." } ;
+
+HELP: inline-libs-directory
+{ $values
+ { "path" "a pathname string" }
+}
+{ $description "The directory where libraries created using " { $snippet "alien.inline" } " are stored." } ;
+
+HELP: library-path
+{ $values
+ { "str" string }
+ { "path" "a pathname string" }
+}
+{ $description "Converts " { $snippet "name" } " into a full path to the corresponding inline library." } ;
+
+HELP: library-suffix
+{ $values
+ { "str" string }
+}
+{ $description "The appropriate shared library suffix for the current OS." } ;
+
+HELP: link-descr
+{ $values
+ { "lang" "a language" }
+ { "descr" sequence }
+}
+{ $description "Returns part of a process description. OS dependent." } ;
+
+ARTICLE: "alien.inline.compiler" "Inline C compiler"
+{ $vocab-link "alien.inline.compiler" }
+;
+
+ABOUT: "alien.inline.compiler"
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators fry generalizations
+io.encodings.ascii io.files io.files.temp io.launcher kernel
+locals make sequences system vocabs.parser words io.directories
+io.pathnames ;
+IN: alien.inline.compiler
+
+SYMBOL: C
+SYMBOL: C++
+
+: inline-libs-directory ( -- path )
+ "alien-inline-libs" resource-path dup make-directories ;
+
+: inline-library-file ( name -- path )
+ inline-libs-directory prepend-path ;
+
+: library-suffix ( -- str )
+ os {
+ { [ dup macosx? ] [ drop ".dylib" ] }
+ { [ dup unix? ] [ drop ".so" ] }
+ { [ dup windows? ] [ drop ".dll" ] }
+ } cond ;
+
+: library-path ( str -- path )
+ '[ "lib" % _ % library-suffix % ] "" make inline-library-file ;
+
+HOOK: compiler os ( lang -- str )
+
+M: word compiler
+ {
+ { C [ "gcc" ] }
+ { C++ [ "g++" ] }
+ } case ;
+
+M: openbsd compiler
+ {
+ { C [ "gcc" ] }
+ { C++ [ "eg++" ] }
+ } case ;
+
+M: windows compiler
+ {
+ { C [ "gcc" ] }
+ { C++ [ "g++" ] }
+ } case ;
+
+HOOK: compiler-descr os ( lang -- descr )
+
+M: word compiler-descr compiler 1array ;
+M: macosx compiler-descr
+ call-next-method cpu x86.64?
+ [ { "-arch" "x86_64" } append ] when ;
+
+HOOK: link-descr os ( lang -- descr )
+
+M: word link-descr drop { "-shared" "-o" } ;
+M: macosx link-descr
+ drop { "-g" "-prebind" "-dynamiclib" "-o" }
+ cpu x86.64? [ { "-arch" "x86_64" } prepend ] when ;
+M: windows link-descr
+ {
+ { C [ { "-mno-cygwin" "-shared" "-o" } ] }
+ { C++ [ { "-lstdc++" "-mno-cygwin" "-shared" "-o" } ] }
+ } case ;
+
+<PRIVATE
+: src-suffix ( lang -- str )
+ {
+ { C [ ".c" ] }
+ { C++ [ ".cpp" ] }
+ } case ;
+
+: link-command ( args in out lang -- descr )
+ [ 2array ] dip [ compiler 1array ] [ link-descr ] bi
+ append prepend prepend ;
+
+:: compile-to-object ( lang contents name -- )
+ name ".o" append temp-file
+ contents name lang src-suffix append temp-file
+ [ ascii set-file-contents ] keep 2array
+ lang compiler-descr { "-fPIC" "-c" "-o" } append prepend
+ try-process ;
+
+:: link-object ( lang args name -- )
+ args name [ library-path ]
+ [ ".o" append temp-file ] bi
+ lang link-command try-process ;
+PRIVATE>
+
+:: compile-to-library ( lang args contents name -- )
+ lang contents name compile-to-object
+ lang args name link-object ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel strings effects quotations ;
+IN: alien.inline
+
+<PRIVATE
+: $binding-note ( x -- )
+ drop
+ { "This word requires that certain variables are correctly bound. "
+ "Call " { $link POSTPONE: define-c-library } " to set them up." } print-element ;
+PRIVATE>
+
+HELP: compile-c-library
+{ $description "Writes, compiles, and links code generated since last invocation of " { $link POSTPONE: define-c-library } ". "
+ "Also calls " { $snippet "add-library" } ". "
+ "This word does nothing if the shared library is younger than the factor source file." }
+{ $notes $binding-note } ;
+
+HELP: c-use-framework
+{ $values
+ { "str" string }
+}
+{ $description "OS X only. Adds " { $snippet "-framework name" } " to linker command." }
+{ $notes $binding-note }
+{ $see-also c-link-to c-link-to/use-framework } ;
+
+HELP: define-c-function
+{ $values
+ { "function" "function name" } { "types" "a sequence of C types" } { "effect" effect } { "body" string }
+}
+{ $description "Defines a C function and a factor word which calls it." }
+{ $notes
+ { $list
+ { "The number of " { $snippet "types" } " must match the " { $snippet "in" } " count of the " { $snippet "effect" } "." }
+ { "There must be only one " { $snippet "out" } " element. It must be a legal C return type with dashes (-) instead of spaces." }
+ $binding-note
+ }
+}
+{ $see-also POSTPONE: define-c-function' } ;
+
+HELP: define-c-function'
+{ $values
+ { "function" "function name" } { "effect" effect } { "body" string }
+}
+{ $description "Defines a C function and a factor word which calls it. See " { $link define-c-function } " for more information." }
+{ $notes
+ { $list
+ { "Each effect element must be a legal C type with dashes (-) instead of spaces. "
+ "C argument names will be generated alphabetically, starting with " { $snippet "a" } "." }
+ $binding-note
+ }
+}
+{ $see-also define-c-function } ;
+
+HELP: c-include
+{ $values
+ { "str" string }
+}
+{ $description "Appends an include line to the C library in scope." }
+{ $notes $binding-note } ;
+
+HELP: define-c-library
+{ $values
+ { "name" string }
+}
+{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " words can be used after this one." } ;
+
+HELP: c-link-to
+{ $values
+ { "str" string }
+}
+{ $description "Adds " { $snippet "-lname" } " to linker command." }
+{ $notes $binding-note }
+{ $see-also c-use-framework c-link-to/use-framework } ;
+
+HELP: c-link-to/use-framework
+{ $values
+ { "str" string }
+}
+{ $description "Equivalent to " { $link c-use-framework } " on OS X and " { $link c-link-to } " everywhere else." }
+{ $notes $binding-note }
+{ $see-also c-link-to c-use-framework } ;
+
+HELP: define-c-struct
+{ $values
+ { "name" string } { "fields" "type/name pairs" }
+}
+{ $description "Defines a C struct and factor words which operate on it." }
+{ $notes $binding-note } ;
+
+HELP: define-c-typedef
+{ $values
+ { "old" "C type" } { "new" "C type" }
+}
+{ $description "Define C and factor typedefs." }
+{ $notes $binding-note } ;
+
+HELP: delete-inline-library
+{ $values
+ { "name" string }
+}
+{ $description "Delete the shared library file corresponding to " { $snippet "name" } "." }
+{ $notes "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " } ;
+
+HELP: with-c-library
+{ $values
+ { "name" string } { "quot" quotation }
+}
+{ $description "Calls " { $link define-c-library } ", then the quotation, then " { $link compile-c-library } ", then sets all variables bound by " { $snippet "define-c-library" } " to " { $snippet "f" } "." } ;
+
+HELP: raw-c
+{ $values { "str" string } }
+{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.inline.compiler alien.inline.types
+alien.libraries alien.parser arrays assocs effects fry
+generalizations grouping io.directories io.files
+io.files.info io.files.temp kernel lexer math math.order
+math.ranges multiline namespaces sequences source-files
+splitting strings system vocabs.loader vocabs.parser words
+alien.c-types alien.structs make parser continuations ;
+IN: alien.inline
+
+SYMBOL: c-library
+SYMBOL: library-is-c++
+SYMBOL: linker-args
+SYMBOL: c-strings
+
+<PRIVATE
+: cleanup-variables ( -- )
+ { c-library library-is-c++ linker-args c-strings }
+ [ off ] each ;
+
+: arg-list ( types -- params )
+ CHAR: a swap length CHAR: a + [a,b]
+ [ 1string ] map ;
+
+: compile-library? ( -- ? )
+ c-library get library-path dup exists? [
+ file get [
+ path>>
+ [ file-info modified>> ] bi@ <=> +lt+ =
+ ] [ drop t ] if*
+ ] [ drop t ] if ;
+
+: compile-library ( -- )
+ library-is-c++ get [ C++ ] [ C ] if
+ linker-args get
+ c-strings get "\n" join
+ c-library get compile-to-library ;
+
+: c-library-name ( name -- name' )
+ [ current-vocab name>> % "_" % % ] "" make ;
+PRIVATE>
+
+: append-function-body ( prototype-str body -- str )
+ [ swap % " {\n" % % "\n}\n" % ] "" make ;
+
+: function-types-effect ( -- function types effect )
+ scan scan swap ")" parse-tokens
+ [ "(" subseq? not ] filter swap parse-arglist ;
+
+: prototype-string ( function types effect -- str )
+ [ [ cify-type ] map ] dip
+ types-effect>params-return cify-type -rot
+ [ " " join ] map ", " join
+ "(" prepend ")" append 3array " " join
+ library-is-c++ get [ "extern \"C\" " prepend ] when ;
+
+: prototype-string' ( function types return -- str )
+ [ dup arg-list ] <effect> prototype-string ;
+
+: factor-function ( function types effect -- word quot effect )
+ annotate-effect [ c-library get ] 3dip
+ [ [ factorize-type ] map ] dip
+ types-effect>params-return factorize-type -roll
+ concat make-function ;
+
+: define-c-library ( name -- )
+ c-library-name c-library set
+ V{ } clone c-strings set
+ V{ } clone linker-args set ;
+
+: compile-c-library ( -- )
+ compile-library? [ compile-library ] when
+ c-library get dup library-path "cdecl" add-library ;
+
+: define-c-function ( function types effect body -- )
+ [
+ [ factor-function define-declared ]
+ [ prototype-string ] 3bi
+ ] dip append-function-body c-strings get push ;
+
+: define-c-function' ( function effect body -- )
+ [
+ [ in>> ] keep
+ [ factor-function define-declared ]
+ [ out>> prototype-string' ] 3bi
+ ] dip append-function-body c-strings get push ;
+
+: c-link-to ( str -- )
+ "-l" prepend linker-args get push ;
+
+: c-use-framework ( str -- )
+ "-framework" swap linker-args get '[ _ push ] bi@ ;
+
+: c-link-to/use-framework ( str -- )
+ os macosx? [ c-use-framework ] [ c-link-to ] if ;
+
+: c-include ( str -- )
+ "#include " prepend c-strings get push ;
+
+: define-c-typedef ( old new -- )
+ [ typedef ] [
+ [ swap "typedef " % % " " % % ";" % ]
+ "" make c-strings get push
+ ] 2bi ;
+
+: define-c-struct ( name fields -- )
+ [ current-vocab swap define-struct ] [
+ over
+ [
+ "typedef struct " % "_" % % " {\n" %
+ [ first2 swap % " " % % ";\n" % ] each
+ "} " % % ";\n" %
+ ] "" make c-strings get push
+ ] 2bi ;
+
+: delete-inline-library ( name -- )
+ c-library-name [ remove-library ]
+ [ library-path dup exists? [ delete-file ] [ drop ] if ] bi ;
+
+: with-c-library ( name quot -- )
+ [ [ define-c-library ] dip call compile-c-library ]
+ [ cleanup-variables ] [ ] cleanup ; inline
+
+: raw-c ( str -- )
+ [ "\n" % % "\n" % ] "" make c-strings get push ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax alien.inline ;
+IN: alien.inline.syntax
+
+HELP: ;C-LIBRARY
+{ $syntax ";C-LIBRARY" }
+{ $description "Writes, compiles, and links code generated since previous invocation of " { $link POSTPONE: C-LIBRARY: } "." }
+{ $see-also POSTPONE: compile-c-library } ;
+
+HELP: C-FRAMEWORK:
+{ $syntax "C-FRAMEWORK: name" }
+{ $description "OS X only. Link to named framework. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
+{ $see-also POSTPONE: c-use-framework } ;
+
+HELP: C-FUNCTION:
+{ $syntax "C-FUNCTION: return name ( args ... )\nbody\n;" }
+{ $description "Appends a function to the C library in scope and defines an FFI word that calls it." }
+{ $examples
+ { $example
+ "USING: alien.inline.syntax prettyprint ;"
+ "IN: cmath.ffi"
+ ""
+ "C-LIBRARY: cmathlib"
+ ""
+ "C-FUNCTION: int add ( int a, int b )"
+ " return a + b;"
+ ";"
+ ""
+ ";C-LIBRARY"
+ ""
+ "1 2 add ."
+ "3" }
+}
+{ $see-also POSTPONE: define-c-function } ;
+
+HELP: C-INCLUDE:
+{ $syntax "C-INCLUDE: name" }
+{ $description "Appends an include line to the C library in scope." }
+{ $see-also POSTPONE: c-include } ;
+
+HELP: C-LIBRARY:
+{ $syntax "C-LIBRARY: name" }
+{ $description "Starts a new C library scope. Other " { $snippet "alien.inline" } " syntax can be used after this word." }
+{ $examples
+ { $example
+ "USING: alien.inline.syntax ;"
+ "IN: rectangle.ffi"
+ ""
+ "C-LIBRARY: rectlib"
+ ""
+ "C-STRUCTURE: rectangle { \"int\" \"width\" } { \"int\" \"height\" } ;"
+ ""
+ "C-FUNCTION: int area ( rectangle c )"
+ " return c.width * c.height;"
+ ";"
+ ""
+ ";C-LIBRARY"
+ "" }
+}
+{ $see-also POSTPONE: define-c-library } ;
+
+HELP: C-LINK/FRAMEWORK:
+{ $syntax "C-LINK/FRAMEWORK: name" }
+{ $description "Equivalent to " { $link POSTPONE: C-FRAMEWORK: } " on OS X and " { $link POSTPONE: C-LINK: } " everywhere else." }
+{ $see-also POSTPONE: c-link-to/use-framework } ;
+
+HELP: C-LINK:
+{ $syntax "C-LINK: name" }
+{ $description "Link to named library. Takes effect when " { $link POSTPONE: ;C-LIBRARY } " is called." }
+{ $see-also POSTPONE: c-link-to } ;
+
+HELP: C-STRUCTURE:
+{ $syntax "C-STRUCTURE: name pairs ... ;" }
+{ $description "Like " { $snippet "C-STRUCT:" } " but also generates equivalent C code."}
+{ $see-also POSTPONE: define-c-struct } ;
+
+HELP: C-TYPEDEF:
+{ $syntax "C-TYPEDEF: old new" }
+{ $description "Like " { $snippet "TYPEDEF:" } " but generates a C typedef statement too." }
+{ $see-also POSTPONE: define-c-typedef } ;
+
+HELP: COMPILE-AS-C++
+{ $syntax "COMPILE-AS-C++" }
+{ $description "Insert this word anywhere between " { $link POSTPONE: C-LIBRARY: } " and " { $link POSTPONE: ;C-LIBRARY } " and the generated code will be treated as C++ with " { $snippet "extern \"C\"" } " prepended to each function prototype." } ;
+
+HELP: DELETE-C-LIBRARY:
+{ $syntax "DELETE-C-LIBRARY: name" }
+{ $description "Deletes the shared library file corresponding to " { $snippet "name" } " . " }
+{ $notes
+ { $list
+ { "Must be executed in the vocabulary where " { $snippet "name" } " is defined. " }
+ "This word is mainly useful for unit tests."
+ }
+}
+{ $see-also POSTPONE: delete-inline-library } ;
+
+HELP: RAW-C:
+{ $syntax "RAW-C:" "body" ";" }
+{ $description "Insert a string into the generated source file. Useful for macros and other details not implemented in " { $snippet "alien.inline" } "." } ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.inline alien.inline.syntax io.directories io.files
+kernel namespaces tools.test alien.c-types alien.structs ;
+IN: alien.inline.syntax.tests
+
+DELETE-C-LIBRARY: test
+C-LIBRARY: test
+
+C-FUNCTION: const-int add ( int a, int b )
+ return a + b;
+;
+
+C-TYPEDEF: double bigfloat
+
+C-FUNCTION: bigfloat smaller ( bigfloat a )
+ return a / 10;
+;
+
+C-STRUCTURE: rectangle
+ { "int" "width" }
+ { "int" "height" } ;
+
+C-FUNCTION: int area ( rectangle c )
+ return c.width * c.height;
+;
+
+;C-LIBRARY
+
+{ 2 1 } [ add ] must-infer-as
+[ 5 ] [ 2 3 add ] unit-test
+
+[ t ] [ "double" "bigfloat" [ resolve-typedef ] bi@ = ] unit-test
+{ 1 1 } [ smaller ] must-infer-as
+[ 1.0 ] [ 10 smaller ] unit-test
+
+[ t ] [ "rectangle" resolve-typedef struct-type? ] unit-test
+{ 1 1 } [ area ] must-infer-as
+[ 20 ] [
+ "rectangle" <c-object>
+ 4 over set-rectangle-width
+ 5 over set-rectangle-height
+ area
+] unit-test
+
+
+DELETE-C-LIBRARY: cpplib
+C-LIBRARY: cpplib
+
+COMPILE-AS-C++
+
+C-INCLUDE: <string>
+
+C-FUNCTION: const-char* hello ( )
+ std::string s("hello world");
+ return s.c_str();
+;
+
+;C-LIBRARY
+
+{ 0 1 } [ hello ] must-infer-as
+[ "hello world" ] [ hello ] unit-test
+
+
+DELETE-C-LIBRARY: compile-error
+C-LIBRARY: compile-error
+
+C-FUNCTION: char* breakme ( )
+ return not a string;
+;
+
+<< [ compile-c-library ] must-fail >>
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.inline lexer multiline namespaces parser ;
+IN: alien.inline.syntax
+
+
+SYNTAX: C-LIBRARY: scan define-c-library ;
+
+SYNTAX: COMPILE-AS-C++ t library-is-c++ set ;
+
+SYNTAX: C-LINK: scan c-link-to ;
+
+SYNTAX: C-FRAMEWORK: scan c-use-framework ;
+
+SYNTAX: C-LINK/FRAMEWORK: scan c-link-to/use-framework ;
+
+SYNTAX: C-INCLUDE: scan c-include ;
+
+SYNTAX: C-FUNCTION:
+ function-types-effect parse-here define-c-function ;
+
+SYNTAX: C-TYPEDEF: scan scan define-c-typedef ;
+
+SYNTAX: C-STRUCTURE:
+ scan parse-definition define-c-struct ;
+
+SYNTAX: ;C-LIBRARY compile-c-library ;
+
+SYNTAX: DELETE-C-LIBRARY: scan delete-inline-library ;
+
+SYNTAX: RAW-C: parse-here raw-c ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types assocs combinators.short-circuit
+continuations effects fry kernel math memoize sequences
+splitting ;
+IN: alien.inline.types
+
+: cify-type ( str -- str' )
+ { { CHAR: - CHAR: space } } substitute ;
+
+: factorize-type ( str -- str' )
+ cify-type
+ "const " ?head drop
+ "unsigned " ?head [ "u" prepend ] when
+ "long " ?head [ "long" prepend ] when
+ " const" ?tail drop ;
+
+: const-pointer? ( str -- ? )
+ cify-type { [ " const" tail? ] [ "&" tail? ] } 1|| ;
+
+: pointer-to-const? ( str -- ? )
+ cify-type "const " head? ;
+
+MEMO: resolved-primitives ( -- seq )
+ primitive-types [ resolve-typedef ] map ;
+
+: primitive-type? ( type -- ? )
+ [
+ factorize-type resolve-typedef [ resolved-primitives ] dip
+ '[ _ = ] any?
+ ] [ 2drop f ] recover ;
+
+: pointer? ( type -- ? )
+ factorize-type [ "*" tail? ] [ "&" tail? ] bi or ;
+
+: type-sans-pointer ( type -- type' )
+ factorize-type [ '[ _ = ] "*&" swap any? ] trim-tail ;
+
+: pointer-to-primitive? ( type -- ? )
+ factorize-type
+ { [ pointer? ] [ type-sans-pointer primitive-type? ] } 1&& ;
+
+: pointer-to-non-const-primitive? ( str -- ? )
+ {
+ [ pointer-to-const? not ]
+ [ factorize-type pointer-to-primitive? ]
+ } 1&& ;
+
+: types-effect>params-return ( types effect -- params return )
+ [ in>> zip ]
+ [ nip out>> dup length 0 > [ first ] [ drop "void" ] if ]
+ 2bi ;
+
+: annotate-effect ( types effect -- types effect' )
+ [ in>> ] [ out>> ] bi [
+ zip
+ [ over pointer-to-primitive? [ ">" prepend ] when ]
+ assoc-map unzip
+ ] dip <effect> ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations sequences
+strings alien alien.c-types math byte-arrays ;
+IN: alien.marshall
+
+<PRIVATE
+: $memory-note ( arg -- )
+ drop "This word returns a pointer to unmanaged memory."
+ print-element ;
+
+: $c-ptr-note ( arg -- )
+ drop "Does nothing if its argument is a non false c-ptr."
+ print-element ;
+
+: $see-article ( arg -- )
+ drop { "See " { $vocab-link "alien.inline" } "." }
+ print-element ;
+PRIVATE>
+
+HELP: ?malloc-byte-array
+{ $values
+ { "c-type" c-type }
+ { "alien" alien }
+}
+{ $description "Does nothing if input is an alien, otherwise assumes it is a byte array and calls "
+ { $snippet "malloc-byte-array" } "."
+}
+{ $notes $memory-note } ;
+
+HELP: alien-wrapper
+{ $var-description "For wrapping C pointers in a structure factor can dispatch on." } ;
+
+HELP: unmarshall-cast
+{ $values
+ { "alien-wrapper" alien-wrapper }
+ { "alien-wrapper'" alien-wrapper }
+}
+{ $description "Called immediately after unmarshalling. Useful for automatically casting to subtypes." } ;
+
+HELP: marshall-bool
+{ $values
+ { "?" "a generalized boolean" }
+ { "n" "0 or 1" }
+}
+{ $description "Marshalls objects to bool." }
+{ $notes "Will treat " { $snippet "0" } " as " { $snippet "t" } "." } ;
+
+HELP: marshall-bool*
+{ $values
+ { "?/seq" "t/f or sequence" }
+ { "alien" alien }
+}
+{ $description "When the argument is a sequence, returns a pointer to an array of bool, "
+ "otherwise returns a pointer to a single bool value."
+}
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-bool**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description "Takes a one or two dimensional array of generalized booleans "
+ "and returns a pointer to the equivalent C structure."
+}
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-primitive
+{ $values
+ { "n" number }
+ { "n" number }
+}
+{ $description "Marshall numbers to C primitives."
+ $nl
+ "Factor marshalls numbers to primitives for FFI calls, so all "
+ "this word does is convert " { $snippet "t" } " to " { $snippet "1" }
+ ", " { $snippet "f" } " to " { $snippet "0" } ", and lets anything else "
+ "pass through untouched."
+} ;
+
+HELP: marshall-char*
+{ $values
+ { "n/seq" "number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-char**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-char**-or-strings
+{ $values
+ { "seq" "a sequence of strings" }
+ { "alien" alien }
+}
+{ $description "Marshalls an array of strings or characters to an array of C strings." }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-char*-or-string
+{ $values
+ { "n/string" "a number or string" }
+ { "alien" alien }
+}
+{ $description "Marshalls a string to a C string or a number to a pointer to " { $snippet "char" } "." }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-double*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-double**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-float*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-float**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-int*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-int**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-long*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-long**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-longlong*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-longlong**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-non-pointer
+{ $values
+ { "alien-wrapper/byte-array" "an alien-wrapper or byte-array" }
+ { "byte-array" byte-array }
+}
+{ $description "Converts argument to a byte array." }
+{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
+
+HELP: marshall-pointer
+{ $values
+ { "obj" object }
+ { "alien" alien }
+}
+{ $description "Converts argument to a C pointer." }
+{ $notes "Can marshall the following types: " { $snippet "alien, f, byte-array, alien-wrapper, struct-array" } "." } ;
+
+HELP: marshall-short*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-short**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-uchar*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-uchar**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-uint*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-uint**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ulong*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ulong**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ulonglong*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ulonglong**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ushort*
+{ $values
+ { "n/seq" "a number or sequence" }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-ushort**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description $see-article }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshall-void**
+{ $values
+ { "seq" sequence }
+ { "alien" alien }
+}
+{ $description "Marshalls a sequence of objects to an array of pointers to void." }
+{ $notes { $list $c-ptr-note $memory-note } } ;
+
+HELP: marshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Given a C type, returns a quotation that will marshall its argument to that type." } ;
+
+HELP: out-arg-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Like " { $link unmarshaller } " but returns an empty quotation "
+ "for all types except pointers to non-const primitives."
+} ;
+
+HELP: pointer-unmarshaller
+{ $values
+ { "type" " a C type string" }
+ { "quot" quotation }
+}
+{ $description "If in the vocab in which this word is called, there is a subclass of " { $link alien-wrapper }
+ " named after the type argument, " { $snippet "pointer-unmarshaller" } " will return a quotation which "
+ "wraps its argument in an instance of that subclass. In any other case it returns an empty quotation."
+}
+{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
+
+HELP: primitive-marshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot/f" "a quotation or f" }
+}
+{ $description "Returns a quotation to marshall objects to the argument type." }
+{ $notes "Not meant to be called directly. Use the output of " { $link marshaller } " instead." } ;
+
+HELP: primitive-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot/f" "a quotation or f" }
+}
+{ $description "Returns a quotation to unmarshall objects from the argument type." }
+{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
+
+HELP: struct-field-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Like " { $link unmarshaller } " but returns a quotation that "
+ "does not call " { $snippet "free" } " on its argument."
+}
+{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
+
+HELP: struct-primitive-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot/f" "a quotation or f" }
+}
+{ $description "Like " { $link primitive-unmarshaller } " but returns a quotation that "
+ "does not call " { $snippet "free" } " on its argument." }
+{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
+
+HELP: struct-unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Returns a quotation which wraps its argument in the subclass of "
+ { $link struct-wrapper } " which matches the " { $snippet "type" } " arg."
+}
+{ $notes "Not meant to be called directly. Use the output of " { $link unmarshaller } " instead." } ;
+
+HELP: struct-wrapper
+{ $var-description "For wrapping C structs in a structure factor can dispatch on." } ;
+
+HELP: unmarshall-bool
+{ $values
+ { "n" number }
+ { "?" "a boolean" }
+}
+{ $description "Unmarshalls a number to a boolean." } ;
+
+HELP: unmarshall-bool*
+{ $values
+ { "alien" alien }
+ { "?" "a boolean" }
+}
+{ $description "Unmarshalls a C pointer to a boolean." } ;
+
+HELP: unmarshall-bool*-free
+{ $values
+ { "alien" alien }
+ { "?" "a boolean" }
+}
+{ $description "Unmarshalls a C pointer to a boolean and frees the pointer." } ;
+
+HELP: unmarshall-char*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-char*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-char*-to-string
+{ $values
+ { "alien" alien }
+ { "string" string }
+}
+{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string." } ;
+
+HELP: unmarshall-char*-to-string-free
+{ $values
+ { "alien" alien }
+ { "string" string }
+}
+{ $description "Unmarshalls a " { $snippet "char" } " pointer to a factor string and frees the pointer." } ;
+
+HELP: unmarshall-double*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-double*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-float*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-float*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-int*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-int*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-long*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-long*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-longlong*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-longlong*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-short*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-short*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-uchar*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-uchar*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-uint*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-uint*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ulong*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ulong*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ulonglong*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ulonglong*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ushort*
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshall-ushort*-free
+{ $values
+ { "alien" alien }
+ { "n" number }
+}
+{ $description $see-article } ;
+
+HELP: unmarshaller
+{ $values
+ { "type" "a C type string" }
+ { "quot" quotation }
+}
+{ $description "Given a C type, returns a quotation that will unmarshall values of that type." } ;
+
+ARTICLE: "alien.marshall" "C marshalling"
+{ $vocab-link "alien.marshall" } " provides alien wrappers and marshalling words for the "
+"automatic marshalling and unmarshalling of C function arguments, return values, and output parameters."
+
+{ $subheading "Important words" }
+"Wrap an alien:" { $subsection alien-wrapper }
+"Wrap a struct:" { $subsection struct-wrapper }
+"Get the marshaller for a C type:" { $subsection marshaller }
+"Get the unmarshaller for a C type:" { $subsection marshaller }
+"Get the unmarshaller for an output parameter:" { $subsection out-arg-unmarshaller }
+"Get the unmarshaller for a struct field:" { $subsection struct-field-unmarshaller }
+$nl
+"Other marshalling and unmarshalling words in this vocabulary are not intended to be "
+"invoked directly."
+$nl
+"Most marshalling words allow non false c-ptrs to pass through unchanged."
+
+{ $subheading "Primitive marshallers" }
+{ $subsection marshall-primitive } "for marshalling primitive values."
+{ $subsection marshall-int* }
+ "marshalls a number or sequence of numbers. If argument is a sequence, returns a pointer "
+ "to a C array, otherwise returns a pointer to a single value."
+{ $subsection marshall-int** }
+"marshalls a 1D or 2D array of numbers. Returns an array of pointers to arrays."
+
+{ $subheading "Primitive unmarshallers" }
+{ $snippet "unmarshall-<prim>*" } " and " { $snippet "unmarshall-<prim>*-free" }
+" for all values of " { $snippet "<prim>" } " in " { $link primitive-types } "."
+{ $subsection unmarshall-int* }
+"unmarshalls a pointer to primitive. Returns a number. "
+"Assumes the pointer is not an array (if it is, only the first value is returned). "
+"C functions that return arrays are not handled correctly by " { $snippet "alien.marshall" }
+" and must be unmarshalled by hand."
+{ $subsection unmarshall-int*-free }
+"unmarshalls a pointer to primitive, and then frees the pointer."
+$nl
+"Primitive values require no unmarshalling. The factor FFI already does this."
+;
+
+ABOUT: "alien.marshall"
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types alien.inline.types
+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 ;
+IN: alien.marshall
+
+<< primitive-types [ [ "void*" = ] [ "bool" = ] bi or not ]
+filter [ define-primitive-marshallers ] each >>
+
+TUPLE: alien-wrapper { underlying alien } ;
+TUPLE: struct-wrapper < alien-wrapper disposed ;
+
+GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
+
+M: alien-wrapper unmarshall-cast ;
+M: struct-wrapper unmarshall-cast ;
+
+M: struct-wrapper dispose* underlying>> free ;
+
+: marshall-pointer ( obj -- alien )
+ {
+ { [ dup alien? ] [ ] }
+ { [ dup not ] [ ] }
+ { [ dup byte-array? ] [ malloc-byte-array ] }
+ { [ dup alien-wrapper? ] [ underlying>> ] }
+ { [ dup struct-array? ] [ underlying>> ] }
+ } cond ;
+
+: marshall-primitive ( n -- n )
+ [ bool>arg ] ptr-pass-through ;
+
+ALIAS: marshall-void* marshall-pointer
+
+: marshall-void** ( seq -- alien )
+ [ marshall-void* ] void*-array{ } map-as malloc-underlying ;
+
+: (marshall-char*-or-string) ( n/string -- alien )
+ dup string?
+ [ utf8 string>alien malloc-byte-array ]
+ [ (marshall-char*) ] if ;
+
+: marshall-char*-or-string ( n/string -- alien )
+ [ (marshall-char*-or-string) ] ptr-pass-through ;
+
+: (marshall-char**-or-strings) ( seq -- alien )
+ [ marshall-char*-or-string ] void*-array{ } map-as
+ malloc-underlying ;
+
+: marshall-char**-or-strings ( seq -- alien )
+ [ (marshall-char**-or-strings) ] ptr-pass-through ;
+
+: marshall-bool ( ? -- n )
+ >boolean [ 1 ] [ 0 ] if ;
+
+: (marshall-bool*) ( ?/seq -- alien )
+ [ marshall-bool <bool> malloc-byte-array ]
+ [ >bool-array malloc-underlying ]
+ marshall-x* ;
+
+: marshall-bool* ( ?/seq -- alien )
+ [ (marshall-bool*) ] ptr-pass-through ;
+
+: (marshall-bool**) ( seq -- alien )
+ [ marshall-bool* ] map >void*-array malloc-underlying ;
+
+: marshall-bool** ( seq -- alien )
+ [ (marshall-bool**) ] ptr-pass-through ;
+
+: unmarshall-bool ( n -- ? )
+ 0 = not ;
+
+: unmarshall-bool* ( alien -- ? )
+ *bool unmarshall-bool ;
+
+: unmarshall-bool*-free ( alien -- ? )
+ [ *bool unmarshall-bool ] keep add-malloc free ;
+
+: primitive-marshaller ( type -- quot/f )
+ {
+ { "bool" [ [ marshall-bool ] ] }
+ { "boolean" [ [ marshall-bool ] ] }
+ { "char" [ [ marshall-primitive ] ] }
+ { "uchar" [ [ marshall-primitive ] ] }
+ { "short" [ [ marshall-primitive ] ] }
+ { "ushort" [ [ marshall-primitive ] ] }
+ { "int" [ [ marshall-primitive ] ] }
+ { "uint" [ [ marshall-primitive ] ] }
+ { "long" [ [ marshall-primitive ] ] }
+ { "ulong" [ [ marshall-primitive ] ] }
+ { "long" [ [ marshall-primitive ] ] }
+ { "ulong" [ [ marshall-primitive ] ] }
+ { "float" [ [ marshall-primitive ] ] }
+ { "double" [ [ marshall-primitive ] ] }
+ { "bool*" [ [ marshall-bool* ] ] }
+ { "boolean*" [ [ marshall-bool* ] ] }
+ { "char*" [ [ marshall-char*-or-string ] ] }
+ { "uchar*" [ [ marshall-uchar* ] ] }
+ { "short*" [ [ marshall-short* ] ] }
+ { "ushort*" [ [ marshall-ushort* ] ] }
+ { "int*" [ [ marshall-int* ] ] }
+ { "uint*" [ [ marshall-uint* ] ] }
+ { "long*" [ [ marshall-long* ] ] }
+ { "ulong*" [ [ marshall-ulong* ] ] }
+ { "longlong*" [ [ marshall-longlong* ] ] }
+ { "ulonglong*" [ [ marshall-ulonglong* ] ] }
+ { "float*" [ [ marshall-float* ] ] }
+ { "double*" [ [ marshall-double* ] ] }
+ { "bool&" [ [ marshall-bool* ] ] }
+ { "boolean&" [ [ marshall-bool* ] ] }
+ { "char&" [ [ marshall-char* ] ] }
+ { "uchar&" [ [ marshall-uchar* ] ] }
+ { "short&" [ [ marshall-short* ] ] }
+ { "ushort&" [ [ marshall-ushort* ] ] }
+ { "int&" [ [ marshall-int* ] ] }
+ { "uint&" [ [ marshall-uint* ] ] }
+ { "long&" [ [ marshall-long* ] ] }
+ { "ulong&" [ [ marshall-ulong* ] ] }
+ { "longlong&" [ [ marshall-longlong* ] ] }
+ { "ulonglong&" [ [ marshall-ulonglong* ] ] }
+ { "float&" [ [ marshall-float* ] ] }
+ { "double&" [ [ marshall-double* ] ] }
+ { "void*" [ [ marshall-void* ] ] }
+ { "bool**" [ [ marshall-bool** ] ] }
+ { "boolean**" [ [ marshall-bool** ] ] }
+ { "char**" [ [ marshall-char**-or-strings ] ] }
+ { "uchar**" [ [ marshall-uchar** ] ] }
+ { "short**" [ [ marshall-short** ] ] }
+ { "ushort**" [ [ marshall-ushort** ] ] }
+ { "int**" [ [ marshall-int** ] ] }
+ { "uint**" [ [ marshall-uint** ] ] }
+ { "long**" [ [ marshall-long** ] ] }
+ { "ulong**" [ [ marshall-ulong** ] ] }
+ { "longlong**" [ [ marshall-longlong** ] ] }
+ { "ulonglong**" [ [ marshall-ulonglong** ] ] }
+ { "float**" [ [ marshall-float** ] ] }
+ { "double**" [ [ marshall-double** ] ] }
+ { "void**" [ [ marshall-void** ] ] }
+ [ drop f ]
+ } case ;
+
+: marshall-non-pointer ( alien-wrapper/byte-array -- byte-array )
+ {
+ { [ dup byte-array? ] [ ] }
+ { [ dup alien-wrapper? ]
+ [ [ underlying>> ] [ class name>> heap-size ] bi
+ memory>byte-array ] }
+ } cond ;
+
+
+: marshaller ( type -- quot )
+ factorize-type dup primitive-marshaller [ nip ] [
+ pointer?
+ [ [ marshall-pointer ] ]
+ [ [ marshall-non-pointer ] ] if
+ ] if* ;
+
+
+: unmarshall-char*-to-string ( alien -- string )
+ utf8 alien>string ;
+
+: unmarshall-char*-to-string-free ( alien -- string )
+ [ unmarshall-char*-to-string ] keep add-malloc free ;
+
+: primitive-unmarshaller ( type -- quot/f )
+ {
+ { "bool" [ [ unmarshall-bool ] ] }
+ { "boolean" [ [ unmarshall-bool ] ] }
+ { "char" [ [ ] ] }
+ { "uchar" [ [ ] ] }
+ { "short" [ [ ] ] }
+ { "ushort" [ [ ] ] }
+ { "int" [ [ ] ] }
+ { "uint" [ [ ] ] }
+ { "long" [ [ ] ] }
+ { "ulong" [ [ ] ] }
+ { "longlong" [ [ ] ] }
+ { "ulonglong" [ [ ] ] }
+ { "float" [ [ ] ] }
+ { "double" [ [ ] ] }
+ { "bool*" [ [ unmarshall-bool*-free ] ] }
+ { "boolean*" [ [ unmarshall-bool*-free ] ] }
+ { "char*" [ [ ] ] }
+ { "uchar*" [ [ unmarshall-uchar*-free ] ] }
+ { "short*" [ [ unmarshall-short*-free ] ] }
+ { "ushort*" [ [ unmarshall-ushort*-free ] ] }
+ { "int*" [ [ unmarshall-int*-free ] ] }
+ { "uint*" [ [ unmarshall-uint*-free ] ] }
+ { "long*" [ [ unmarshall-long*-free ] ] }
+ { "ulong*" [ [ unmarshall-ulong*-free ] ] }
+ { "longlong*" [ [ unmarshall-long*-free ] ] }
+ { "ulonglong*" [ [ unmarshall-ulong*-free ] ] }
+ { "float*" [ [ unmarshall-float*-free ] ] }
+ { "double*" [ [ unmarshall-double*-free ] ] }
+ { "bool&" [ [ unmarshall-bool*-free ] ] }
+ { "boolean&" [ [ unmarshall-bool*-free ] ] }
+ { "char&" [ [ ] ] }
+ { "uchar&" [ [ unmarshall-uchar*-free ] ] }
+ { "short&" [ [ unmarshall-short*-free ] ] }
+ { "ushort&" [ [ unmarshall-ushort*-free ] ] }
+ { "int&" [ [ unmarshall-int*-free ] ] }
+ { "uint&" [ [ unmarshall-uint*-free ] ] }
+ { "long&" [ [ unmarshall-long*-free ] ] }
+ { "ulong&" [ [ unmarshall-ulong*-free ] ] }
+ { "longlong&" [ [ unmarshall-longlong*-free ] ] }
+ { "ulonglong&" [ [ unmarshall-ulonglong*-free ] ] }
+ { "float&" [ [ unmarshall-float*-free ] ] }
+ { "double&" [ [ unmarshall-double*-free ] ] }
+ [ drop f ]
+ } case ;
+
+: struct-primitive-unmarshaller ( type -- quot/f )
+ {
+ { "bool" [ [ unmarshall-bool ] ] }
+ { "boolean" [ [ unmarshall-bool ] ] }
+ { "char" [ [ ] ] }
+ { "uchar" [ [ ] ] }
+ { "short" [ [ ] ] }
+ { "ushort" [ [ ] ] }
+ { "int" [ [ ] ] }
+ { "uint" [ [ ] ] }
+ { "long" [ [ ] ] }
+ { "ulong" [ [ ] ] }
+ { "longlong" [ [ ] ] }
+ { "ulonglong" [ [ ] ] }
+ { "float" [ [ ] ] }
+ { "double" [ [ ] ] }
+ { "bool*" [ [ unmarshall-bool* ] ] }
+ { "boolean*" [ [ unmarshall-bool* ] ] }
+ { "char*" [ [ ] ] }
+ { "uchar*" [ [ unmarshall-uchar* ] ] }
+ { "short*" [ [ unmarshall-short* ] ] }
+ { "ushort*" [ [ unmarshall-ushort* ] ] }
+ { "int*" [ [ unmarshall-int* ] ] }
+ { "uint*" [ [ unmarshall-uint* ] ] }
+ { "long*" [ [ unmarshall-long* ] ] }
+ { "ulong*" [ [ unmarshall-ulong* ] ] }
+ { "longlong*" [ [ unmarshall-long* ] ] }
+ { "ulonglong*" [ [ unmarshall-ulong* ] ] }
+ { "float*" [ [ unmarshall-float* ] ] }
+ { "double*" [ [ unmarshall-double* ] ] }
+ { "bool&" [ [ unmarshall-bool* ] ] }
+ { "boolean&" [ [ unmarshall-bool* ] ] }
+ { "char&" [ [ unmarshall-char* ] ] }
+ { "uchar&" [ [ unmarshall-uchar* ] ] }
+ { "short&" [ [ unmarshall-short* ] ] }
+ { "ushort&" [ [ unmarshall-ushort* ] ] }
+ { "int&" [ [ unmarshall-int* ] ] }
+ { "uint&" [ [ unmarshall-uint* ] ] }
+ { "long&" [ [ unmarshall-long* ] ] }
+ { "ulong&" [ [ unmarshall-ulong* ] ] }
+ { "longlong&" [ [ unmarshall-longlong* ] ] }
+ { "ulonglong&" [ [ unmarshall-ulonglong* ] ] }
+ { "float&" [ [ unmarshall-float* ] ] }
+ { "double&" [ [ unmarshall-double* ] ] }
+ [ drop f ]
+ } case ;
+
+
+: ?malloc-byte-array ( c-type -- alien )
+ dup alien? [ malloc-byte-array ] unless ;
+
+: struct-unmarshaller ( type -- quot )
+ current-vocab lookup [
+ dup superclasses [ \ struct-wrapper = ] any? [
+ '[ ?malloc-byte-array _ new swap >>underlying ]
+ ] [ drop [ ] ] if
+ ] [ [ ] ] if* ;
+
+: pointer-unmarshaller ( type -- quot )
+ type-sans-pointer current-vocab lookup [
+ dup superclasses [ \ alien-wrapper = ] any? [
+ '[ _ new swap >>underlying unmarshall-cast ]
+ ] [ drop [ ] ] if
+ ] [ [ ] ] if* ;
+
+: unmarshaller ( type -- quot )
+ factorize-type dup primitive-unmarshaller [ nip ] [
+ dup pointer?
+ [ pointer-unmarshaller ]
+ [ struct-unmarshaller ] if
+ ] if* ;
+
+: struct-field-unmarshaller ( type -- quot )
+ factorize-type dup struct-primitive-unmarshaller [ nip ] [
+ dup pointer?
+ [ pointer-unmarshaller ]
+ [ struct-unmarshaller ] if
+ ] if* ;
+
+: out-arg-unmarshaller ( type -- quot )
+ dup pointer-to-non-const-primitive?
+ [ factorize-type primitive-unmarshaller ]
+ [ drop [ drop ] ] if ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! 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
+combinators.short-circuit ;
+IN: alien.marshall.private
+
+: bool>arg ( ? -- 1/0/obj )
+ {
+ { t [ 1 ] }
+ { f [ 0 ] }
+ [ ]
+ } case ;
+
+MACRO: marshall-x* ( num-quot seq-quot -- alien )
+ '[ bool>arg dup number? _ _ if ] ;
+
+: ptr-pass-through ( obj quot -- alien )
+ over { [ c-ptr? ] [ ] } 1&& [ drop ] [ call ] if ; inline
+
+: malloc-underlying ( obj -- alien )
+ underlying>> malloc-byte-array ;
+
+FUNCTOR: define-primitive-marshallers ( TYPE -- )
+<TYPE> IS <${TYPE}>
+*TYPE IS *${TYPE}
+>TYPE-array IS >${TYPE}-array
+marshall-TYPE DEFINES marshall-${TYPE}
+(marshall-TYPE*) DEFINES (marshall-${TYPE}*)
+(marshall-TYPE**) DEFINES (marshall-${TYPE}**)
+marshall-TYPE* DEFINES marshall-${TYPE}*
+marshall-TYPE** DEFINES marshall-${TYPE}**
+marshall-TYPE*-free DEFINES marshall-${TYPE}*-free
+marshall-TYPE**-free DEFINES marshall-${TYPE}**-free
+unmarshall-TYPE* DEFINES unmarshall-${TYPE}*
+unmarshall-TYPE*-free DEFINES unmarshall-${TYPE}*-free
+WHERE
+<PRIVATE
+: (marshall-TYPE*) ( n/seq -- alien )
+ [ <TYPE> malloc-byte-array ]
+ [ >TYPE-array malloc-underlying ]
+ marshall-x* ;
+PRIVATE>
+: marshall-TYPE* ( n/seq -- alien )
+ [ (marshall-TYPE*) ] ptr-pass-through ;
+<PRIVATE
+: (marshall-TYPE**) ( seq -- alien )
+ [ marshall-TYPE* ] void*-array{ } map-as malloc-underlying ;
+PRIVATE>
+: marshall-TYPE** ( seq -- alien )
+ [ (marshall-TYPE**) ] ptr-pass-through ;
+: unmarshall-TYPE* ( alien -- n )
+ *TYPE ; inline
+: unmarshall-TYPE*-free ( alien -- n )
+ [ unmarshall-TYPE* ] keep add-malloc free ;
+;FUNCTOR
+
+SYNTAX: PRIMITIVE-MARSHALLERS:
+";" parse-tokens [ define-primitive-marshallers ] each ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes help.markup help.syntax kernel quotations words
+alien.marshall.structs strings alien.structs alien.marshall ;
+IN: alien.marshall.structs
+
+HELP: define-marshalled-struct
+{ $values
+ { "name" string } { "vocab" "a vocabulary specifier" } { "fields" "an alist" }
+}
+{ $description "Calls " { $link define-struct } " and " { $link define-struct-tuple } "." } ;
+
+HELP: define-struct-tuple
+{ $values
+ { "name" string }
+}
+{ $description "Defines a subclass of " { $link struct-wrapper } ", a constructor, "
+ "and accessor words."
+} ;
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.marshall arrays assocs
+classes.tuple combinators destructors generalizations generic
+kernel libc locals parser quotations sequences slots words
+alien.structs lexer vocabs.parser fry effects ;
+IN: alien.marshall.structs
+
+<PRIVATE
+: define-struct-accessor ( class name quot -- )
+ [ "accessors" create create-method dup make-inline ] dip define ;
+
+: define-struct-getter ( class name word type -- )
+ [ ">>" append \ underlying>> ] 2dip
+ struct-field-unmarshaller \ call 4array >quotation
+ define-struct-accessor ;
+
+: define-struct-setter ( class name word type -- )
+ [ "(>>" prepend ")" append ] 2dip
+ marshaller [ underlying>> ] \ bi* roll 4array >quotation
+ define-struct-accessor ;
+
+: define-struct-accessors ( class name type reader writer -- )
+ [ dup define-protocol-slot ] 3dip
+ [ drop swap define-struct-getter ]
+ [ nip swap define-struct-setter ] 5 nbi ;
+
+: define-struct-constructor ( class -- )
+ {
+ [ name>> "<" prepend ">" append create-in ]
+ [ '[ _ new ] ]
+ [ name>> '[ _ malloc-object >>underlying ] append ]
+ [ name>> 1array ]
+ } cleave { } swap <effect> define-declared ;
+PRIVATE>
+
+:: define-struct-tuple ( name -- )
+ name create-in :> class
+ class struct-wrapper { } define-tuple-class
+ class define-struct-constructor
+ name c-type fields>> [
+ class swap
+ {
+ [ name>> { { CHAR: space CHAR: - } } substitute ]
+ [ type>> ] [ reader>> ] [ writer>> ]
+ } cleave define-struct-accessors
+ ] each ;
+
+: define-marshalled-struct ( name vocab fields -- )
+ [ define-struct ] [ 2drop define-struct-tuple ] 3bi ;
--- /dev/null
+Jeremy Hughes
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations words
+alien.inline alien.syntax effects alien.marshall
+alien.marshall.structs strings sequences alien.inline.syntax ;
+IN: alien.marshall.syntax
+
+HELP: CM-FUNCTION:
+{ $syntax "CM-FUNCTION: return name args\n body\n;" }
+{ $description "Like " { $link POSTPONE: C-FUNCTION: } " but with marshalling "
+ "of arguments and return values."
+}
+{ $examples
+ { $example
+ "USING: alien.inline.syntax alien.marshall.syntax prettyprint ;"
+ "IN: example"
+ ""
+ "C-LIBRARY: exlib"
+ ""
+ "C-INCLUDE: <stdio.h>"
+ "CM-FUNCTION: char* sum_diff ( const-int a, const-int b, int* x, int* y )"
+ " *x = a + b;"
+ " *y = a - b;"
+ " char* s = (char*) malloc(sizeof(char) * 64);"
+ " sprintf(s, \"sum %i, diff %i\", *x, *y);"
+ " return s;"
+ ";"
+ ""
+ ";C-LIBRARY"
+ ""
+ "8 5 0 0 sum_diff . . ."
+ "3\n13\n\"sum 13, diff 3\""
+ }
+}
+{ $see-also define-c-marshalled POSTPONE: C-FUNCTION: POSTPONE: M-FUNCTION: } ;
+
+HELP: CM-STRUCTURE:
+{ $syntax "CM-STRUCTURE: name fields ... ;" }
+{ $description "Like " { $link POSTPONE: C-STRUCTURE: } " but with marshalling of fields. "
+ "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
+}
+{ $see-also POSTPONE: C-STRUCTURE: POSTPONE: M-STRUCTURE: } ;
+
+HELP: M-FUNCTION:
+{ $syntax "M-FUNCTION: return name args ;" }
+{ $description "Like " { $link POSTPONE: FUNCTION: } " but with marshalling "
+ "of arguments and return values."
+}
+{ $see-also marshalled-function POSTPONE: C-FUNCTION: POSTPONE: CM-FUNCTION: } ;
+
+HELP: M-STRUCTURE:
+{ $syntax "M-STRUCTURE: name fields ... ;" }
+{ $description "Like " { $link POSTPONE: C-STRUCT: } " but with marshalling of fields. "
+ "Defines a subclass of " { $link struct-wrapper } " a constructor, and slot-like accessor words."
+}
+{ $see-also define-marshalled-struct POSTPONE: C-STRUCTURE: POSTPONE: CM-STRUCTURE: } ;
+
+HELP: define-c-marshalled
+{ $values
+ { "name" string } { "types" sequence } { "effect" effect } { "body" string }
+}
+{ $description "Defines a C function and a factor word which calls it with marshalling of "
+ "args and return values."
+}
+{ $see-also define-c-marshalled' } ;
+
+HELP: define-c-marshalled'
+{ $values
+ { "name" string } { "effect" effect } { "body" string }
+}
+{ $description "Like " { $link define-c-marshalled } ". "
+ "The effect elements must be C type strings."
+} ;
+
+HELP: marshalled-function
+{ $values
+ { "name" string } { "types" sequence } { "effect" effect }
+ { "word" word } { "quot" quotation } { "effect" effect }
+}
+{ $description "Defines a word which calls the named C function. Arguments, "
+ "return value, and output parameters are marshalled and unmarshalled."
+} ;
+
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.inline.syntax alien.marshall.syntax destructors
+tools.test accessors kernel ;
+IN: alien.marshall.syntax.tests
+
+DELETE-C-LIBRARY: test
+C-LIBRARY: test
+
+C-INCLUDE: <stdlib.h>
+C-INCLUDE: <string.h>
+
+C-TYPEDEF: char bool
+
+CM-FUNCTION: void outarg1 ( int* a )
+ *a += 2;
+;
+
+CM-FUNCTION: unsigned-long* outarg2 ( unsigned-long a, unsigned-long* b )
+ unsigned long* x = malloc(sizeof(unsigned long*));
+ *b = 10 + *b;
+ *x = a + *b;
+ return x;
+;
+
+CM-STRUCTURE: wedge
+ { "double" "degrees" } ;
+
+CM-STRUCTURE: sundial
+ { "double" "radius" }
+ { "wedge" "wedge" } ;
+
+CM-FUNCTION: double hours ( sundial* d )
+ return d->wedge.degrees / 30;
+;
+
+CM-FUNCTION: void change_time ( double hours, sundial* d )
+ d->wedge.degrees = hours * 30;
+;
+
+CM-FUNCTION: bool c_not ( bool p )
+ return !p;
+;
+
+CM-FUNCTION: char* upcase ( const-char* s )
+ int len = strlen(s);
+ char* t = malloc(sizeof(char) * len);
+ int i;
+ for (i = 0; i < len; i++)
+ t[i] = toupper(s[i]);
+ t[i] = '\0';
+ return t;
+;
+
+;C-LIBRARY
+
+{ 1 1 } [ outarg1 ] must-infer-as
+[ 3 ] [ 1 outarg1 ] unit-test
+[ 3 ] [ t outarg1 ] unit-test
+[ 2 ] [ f outarg1 ] unit-test
+
+{ 2 2 } [ outarg2 ] must-infer-as
+[ 18 15 ] [ 3 5 outarg2 ] unit-test
+
+{ 1 1 } [ hours ] must-infer-as
+[ 5.0 ] [ <sundial> <wedge> 150 >>degrees >>wedge hours ] unit-test
+
+{ 2 0 } [ change_time ] must-infer-as
+[ 150.0 ] [ 5 <sundial> <wedge> 11 >>degrees >>wedge [ change_time ] keep wedge>> degrees>> ] unit-test
+
+{ 1 1 } [ c_not ] must-infer-as
+[ f ] [ "x" c_not ] unit-test
+[ f ] [ 0 c_not ] unit-test
+
+{ 1 1 } [ upcase ] must-infer-as
+[ "ABC" ] [ "abc" upcase ] unit-test
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.inline alien.inline.types alien.marshall
+combinators effects generalizations kernel locals make namespaces
+quotations sequences words alien.marshall.structs lexer parser
+vocabs.parser multiline ;
+IN: alien.marshall.syntax
+
+:: marshalled-function ( name types effect -- word quot effect )
+ name types effect factor-function
+ [ in>> ]
+ [ out>> types [ pointer-to-non-const-primitive? ] filter append ]
+ bi <effect>
+ [
+ [
+ types [ marshaller ] map , \ spread , ,
+ types length , \ nkeep ,
+ types [ out-arg-unmarshaller ] map
+ effect out>> dup empty?
+ [ drop ] [ first unmarshaller prefix ] if
+ , \ spread ,
+ ] [ ] make
+ ] dip ;
+
+: define-c-marshalled ( name types effect body -- )
+ [
+ [ marshalled-function define-declared ]
+ [ prototype-string ] 3bi
+ ] dip append-function-body c-strings get push ;
+
+: define-c-marshalled' ( name effect body -- )
+ [
+ [ in>> ] keep
+ [ marshalled-function define-declared ]
+ [ out>> prototype-string' ] 3bi
+ ] dip append-function-body c-strings get push ;
+
+SYNTAX: CM-FUNCTION:
+ function-types-effect parse-here define-c-marshalled ;
+
+SYNTAX: M-FUNCTION:
+ function-types-effect marshalled-function define-declared ;
+
+SYNTAX: M-STRUCTURE:
+ scan current-vocab parse-definition
+ define-marshalled-struct ;
+
+SYNTAX: CM-STRUCTURE:
+ scan current-vocab parse-definition
+ [ define-marshalled-struct ] [ nip define-c-struct ] 3bi ;
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vocabs vocabs.loader tools.time vocabs.hierarchy
arrays assocs io.styles io help.markup prettyprint sequences
-continuations debugger math namespaces memory ;
+continuations debugger math namespaces memory fry ;
IN: benchmark
<PRIVATE
PRIVATE>
+: (run-benchmark) ( vocab -- time )
+ [ 5 ] dip '[ gc [ _ run ] benchmark ] replicate infimum ;
+
: run-benchmark ( vocab -- )
- [ "=== " write vocab-name print flush ] [
- [ [ require ] [ gc [ run ] benchmark ] [ ] tri timings ]
+ [ "=== " write print flush ] [
+ [ [ require ] [ (run-benchmark) ] [ ] tri timings ]
[ swap errors ]
recover get set-at
] bi ;
[
V{ } clone timings set
V{ } clone errors set
- "benchmark" all-child-vocabs-seq
+ "benchmark" child-vocab-names
+ [ find-vocab-root ] filter
[ run-benchmark ] each
timings get
errors get
--- /dev/null
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators kernel locals math
+math.ranges memoize sequences strings hashtables
+math.parser grouping ;
+IN: benchmark.hashtables
+
+MEMO: strings ( -- str )
+ 1 100 [a,b] 1 [ + ] accumulate nip [ number>string ] map ;
+
+:: add-delete-mix ( hash keys -- )
+ keys [| k |
+ 0 k hash set-at
+ k hash delete-at
+ ] each
+
+ keys [
+ 0 swap hash set-at
+ ] each
+
+ keys [
+ hash delete-at
+ ] each ;
+
+:: store-lookup-mix ( hash keys -- )
+ keys [
+ 0 swap hash set-at
+ ] each
+
+ keys [
+ hash at
+ ] map drop
+
+ keys [
+ hash [ 1 + ] change-at
+ ] each ;
+
+: string-mix ( hash -- )
+ strings
+ [ add-delete-mix ]
+ [ store-lookup-mix ]
+ 2bi ;
+
+TUPLE: collision value ;
+
+M: collision hashcode* value>> hashcode* 15 bitand ;
+
+: collision-mix ( hash -- )
+ strings 30 head [ collision boa ] map
+ [ add-delete-mix ]
+ [ store-lookup-mix ]
+ 2bi ;
+
+: small-mix ( hash -- )
+ strings 10 group [
+ [ add-delete-mix ]
+ [ store-lookup-mix ]
+ 2bi
+ ] with each ;
+
+: hashtable-benchmark ( -- )
+ H{ } clone
+ 10000 [
+ dup {
+ [ small-mix ]
+ [ clear-assoc ]
+ [ string-mix ]
+ [ clear-assoc ]
+ [ collision-mix ]
+ [ clear-assoc ]
+ } cleave
+ ] times
+ drop ;
+
+MAIN: hashtable-benchmark
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: heaps math sequences kernel ;
+IN: benchmark.heaps
+
+: data ( -- seq )
+ 1 6000 [ 13 + 79 * 13591 mod dup ] replicate nip ;
+
+: heap-test ( -- )
+ <min-heap>
+ data
+ [ [ dup pick heap-push ] each ]
+ [ length [ dup heap-pop* ] times ] bi
+ drop ;
+
+: heap-benchmark ( -- )
+ 100 [ heap-test ] times ;
+
+MAIN: heap-benchmark
\ No newline at end of file
--- /dev/null
+USING: bson.reader bson.writer byte-arrays io.encodings.binary
+io.streams.byte-array tools.test literals calendar kernel math ;
+
+IN: bson.tests
+
+: turnaround ( value -- value )
+ assoc>bv >byte-array binary [ H{ } stream>assoc ] with-byte-reader ;
+
+[ H{ { "a" "a string" } } ] [ H{ { "a" "a string" } } turnaround ] unit-test
+
+[ H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } ]
+[ H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } turnaround ] unit-test
+
+[ H{ { "a list" { 1 2.234 "hello world" } } } ]
+[ H{ { "a list" { 1 2.234 "hello world" } } } turnaround ] unit-test
+
+[ H{ { "a quotation" [ 1 2 + ] } } ]
+[ H{ { "a quotation" [ 1 2 + ] } } turnaround ] unit-test
+
+[ H{ { "a date" T{ timestamp { year 2009 }
+ { month 7 }
+ { day 11 }
+ { hour 9 }
+ { minute 8 }
+ { second 40+77/1000 } } } }
+]
+[ H{ { "a date" T{ timestamp { year 2009 }
+ { month 7 }
+ { day 11 }
+ { hour 11 }
+ { minute 8 }
+ { second 40+15437/200000 }
+ { gmt-offset T{ duration { hour 2 } } } } } } turnaround
+] unit-test
+
+[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
+ { "array" H{ { "a list" { 1 2.234 "hello world" } } } }
+ { "quot" [ 1 2 + ] } }
+]
+[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
+ { "array" H{ { "a list" { 1 2.234 "hello world" } } } }
+ { "quot" [ 1 2 + ] } } turnaround ] unit-test
+
+
-USING: accessors assocs bson.constants byte-arrays byte-vectors fry io
-io.binary io.encodings.string io.encodings.utf8 kernel math namespaces
-sequences serialize arrays calendar io.encodings ;
+USING: accessors assocs bson.constants calendar fry io io.binary
+io.encodings io.encodings.utf8 kernel math math.bitwise namespaces
+sequences serialize ;
FROM: kernel.private => declare ;
FROM: io.encodings.private => (read-until) ;
GENERIC: element-data-read ( type -- object )
GENERIC: element-binary-read ( length type -- object )
-: byte-array>number ( seq -- number )
- byte-array>bignum >integer ; inline
-
: get-state ( -- state )
state get ; inline
: read-int32 ( -- int32 )
- 4 read byte-array>number ; inline
+ 4 read signed-le> ; inline
: read-longlong ( -- longlong )
- 8 read byte-array>number ; inline
+ 8 read signed-le> ; inline
: read-double ( -- double )
- 8 read byte-array>number bits>double ; inline
+ 8 read le> bits>double ; inline
: read-byte-raw ( -- byte-raw )
1 read ; inline
: write-utf8-string ( string -- ) output-stream get '[ _ swap char>utf8 ] each ; inline
-: write-byte ( byte -- ) CHAR-SIZE >le write ; inline
: write-int32 ( int -- ) INT32-SIZE >le write ; inline
: write-double ( real -- ) double>bits INT64-SIZE >le write ; inline
-: write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline
+: write-cstring ( string -- ) write-utf8-string 0 write1 ; inline
: write-longlong ( object -- ) INT64-SIZE >le write ; inline
-: write-eoo ( -- ) T_EOO write-byte ; inline
-: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline
+: write-eoo ( -- ) T_EOO write1 ; inline
+: write-type ( obj -- obj ) [ bson-type? write1 ] keep ; inline
: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
M: string bson-write ( obj -- )
'[ _ write-cstring ] with-length-prefix-excl ;
M: f bson-write ( f -- )
- drop 0 write-byte ;
+ drop 0 write1 ;
M: t bson-write ( t -- )
- drop 1 write-byte ;
+ drop 1 write1 ;
M: integer bson-write ( num -- )
write-int32 ;
M: byte-array bson-write ( binary -- )
[ length write-int32 ] keep
- T_Binary_Bytes write-byte
+ T_Binary_Bytes write1
write ;
M: oid bson-write ( oid -- )
: (serialize-code) ( code -- )
object>bytes [ length write-int32 ] keep
- T_Binary_Custom write-byte
+ T_Binary_Custom write1
write ;
M: quotation bson-write ( quotation -- )
--- /dev/null
+Matthew Willis
--- /dev/null
+USING: central destructors help.markup help.syntax ;
+
+HELP: CENTRAL:
+{ $description
+ "This parsing word defines a pair of words useful for "
+ "implementing the \"central\" pattern: " { $snippet "symbol" } " and "
+ { $snippet "with-symbol" } ". This is a middle ground between excessive "
+ "stack manipulation and full-out locals, meant to solve the case where "
+ "one object is operated on by several related words."
+} ;
+
+HELP: DISPOSABLE-CENTRAL:
+{ $description
+ "Like " { $link POSTPONE: CENTRAL: } ", but generates " { $snippet "with-" }
+ " words that are wrapped in a " { $link with-disposal } "."
+} ;
\ No newline at end of file
--- /dev/null
+USING: accessors central destructors kernel math tools.test ;
+
+IN: scratchpad
+
+CENTRAL: test-central
+
+[ 3 ] [ 3 [ test-central ] with-test-central ] unit-test
+
+TUPLE: test-disp-cent value disposed ;
+
+! A phony destructor that adds 1 to the value so we can make sure it got called.
+M: test-disp-cent dispose* dup value>> 1+ >>value drop ;
+
+DISPOSABLE-CENTRAL: t-d-c
+
+: test-t-d-c ( -- n )
+ test-disp-cent new 3 >>value [ t-d-c ] with-t-d-c value>> ;
+
+[ 4 ] [ test-t-d-c ] unit-test
\ No newline at end of file
--- /dev/null
+USING: destructors kernel lexer namespaces parser sequences words ;
+
+IN: central
+
+: define-central-getter ( word -- )
+ dup [ get ] curry (( -- obj )) define-declared ;
+
+: define-centrals ( str -- getter setter )
+ [ create-in dup define-central-getter ]
+ [ "with-" prepend create-in dup make-inline ] bi ;
+
+: central-setter-def ( word with-word -- with-word quot )
+ [ with-variable ] with ;
+
+: disposable-setter-def ( word with-word -- with-word quot )
+ [ pick [ drop with-variable ] with-disposal ] with ;
+
+: declare-central ( with-word quot -- ) (( object quot -- )) define-declared ;
+
+: define-central ( word-name -- )
+ define-centrals central-setter-def declare-central ;
+
+: define-disposable-central ( word-name -- )
+ define-centrals disposable-setter-def declare-central ;
+
+SYNTAX: CENTRAL: ( -- ) scan define-central ;
+
+SYNTAX: DISPOSABLE-CENTRAL: ( -- ) scan define-disposable-central ;
\ No newline at end of file
--- /dev/null
+extensions
: changelog ( -- authors )
image parent-directory [
- "git log --pretty=format:%an" ascii <process-reader> stream-lines
+ "git log --
no-merges --pretty=format:%an" ascii <process-reader> stream-lines
] with-directory ;
: patch-counts ( authors -- assoc )
[ { 111 222 } ]
[ { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ] unit-test
+
+: test-3map ( -- seq )
+ { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ;
+
+[ { 111 222 } ] [ test-3map ] unit-test
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generalizations kernel math sequences
-sequences.private ;
+sequences.private fry ;
IN: cursors
GENERIC: cursor-done? ( cursor -- ? )
: 2map ( seq1 seq2 quot -- ) [ cursor-map2 ] transform2 ; inline
: find-done3? ( cursor1 cursor2 cursor3 quot -- ? )
- 3 nover 3array [ cursor-done? ] any?
- [ 4 ndrop t ] [ [ [ cursor-get-unsafe ] tri@ ] dip call ] if ; inline
+ [ 3 ndrop t ] swap '[ [ cursor-get-unsafe ] tri@ @ ]
+ [ 3 ndup 3 narray [ cursor-done? ] any? ] 2dip if ; inline
: cursor-until3 ( cursor cursor quot -- )
[ find-done3? not ]
- [ drop [ cursor-advance ] tri@ ] bi-curry bi-curry bi-curry bi-curry while ; inline
+ [ drop [ cursor-advance ] tri@ ]
+ bi-curry bi-curry bi-curry bi-curry while ; inline
: cursor-each3 ( cursor cursor quot -- )
[ f ] compose cursor-until3 ; inline
parser prettyprint sequences summary help.vocabs
vocabs vocabs.loader vocabs.hierarchy vocabs.metadata words see
listener ;
-
+FROM: vocabs.hierarchy => child-vocabs ;
IN: fuel.help
<PRIVATE
[ fuel-vocab-help-table ] bi*
[ 2array ] [ drop f ] if*
] if-empty
- ] { } assoc>map [ ] filter ;
+ ] { } assoc>map sift ;
: fuel-vocab-children-help ( name -- element )
- all-child-vocabs fuel-vocab-list ; inline
+ child-vocabs fuel-vocab-list ; inline
: fuel-vocab-describe-words ( name -- element )
[ words. ] with-string-writer \ describe-words swap 2array ; inline
: article-location ( name -- loc ) article loc>> get-loc ;
-: get-vocabs ( -- seq ) all-vocabs-seq [ vocab-name ] map ;
+: get-vocabs ( -- seq ) all-vocab-names ;
: get-vocabs/prefix ( prefix -- seq ) get-vocabs swap filter-prefix ;
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: alien byte-arrays destructors help.markup help.syntax kernel math
+quotations ;
+IN: gpu.buffers
+
+HELP: <buffer-ptr>
+{ $values
+ { "buffer" buffer } { "offset" integer }
+ { "buffer-ptr" buffer-ptr }
+}
+{ $description "Constructs a " { $link buffer-ptr } " tuple." } ;
+
+HELP: <buffer>
+{ $values
+ { "upload" buffer-upload-pattern }
+ { "usage" buffer-usage-pattern }
+ { "kind" buffer-kind }
+ { "size" integer }
+ { "initial-data" { $maybe c-ptr } }
+ { "buffer" buffer }
+}
+{ $description "Allocates a new " { $link buffer } " object of " { $snippet "size" } " bytes. If " { $snippet "initial-data" } " is not " { $link f } ", " { $snippet "size" } " bytes are copied from " { $snippet "initial-data" } " into the buffer to initialize it; otherwise, the buffer content is left uninitialized. " { $snippet "upload" } ", " { $snippet "usage" } ", and " { $snippet "kind" } " provide hints to the implementation about the expected usage pattern of the buffer as documented in the " { $link buffer } " class documentation." } ;
+
+HELP: allocate-buffer
+{ $values
+ { "buffer" buffer } { "size" integer } { "initial-data" { $maybe c-ptr } }
+}
+{ $description "Discards any memory currently held by " { $snippet "buffer" } " and reallocates a new memory block of " { $snippet "size" } " bytes for it. If " { $snippet "initial-data" } " is not " { $link f } ", " { $snippet "size" } " bytes are copied from " { $snippet "initial-data" } " into the buffer to initialize it; otherwise, the buffer content is left uninitialized." } ;
+
+HELP: buffer
+{ $class-description "Objects of this class represent GPU-accessible memory buffers. Buffer objects can be used to store vertex data and to update or read pixel data from textures and framebuffers without CPU involvement. The data inside buffer objects may be resident in main memory or different parts of GPU memory; the graphics driver will choose a location for a buffer based on usage hints specified when the buffer object is constructed with " { $link <buffer> } " or " { $link byte-array>buffer } ":"
+{ $list
+{ { $snippet "upload-pattern" } " is one of the " { $link buffer-upload-pattern } " values and indicates how frequently the data in the buffer will be updated with new data from CPU memory." }
+{ { $snippet "usage-pattern" } " is one of the " { $link buffer-usage-pattern } " values and indicates how frequently the data in the buffer will be updated with new data from CPU memory." }
+{ { $snippet "kind" } " is one of the " { $link buffer-kind } " values and indicates the primary purpose of the buffer." }
+}
+"These settings are only performance hints and do not restrict the usage of the buffer in any way. For example, a buffer constructed as a " { $link vertex-buffer } " with " { $link static-upload } " can still receive pixel data as though it were a " { $link pixel-pack-buffer } ", and can still be updated with " { $link copy-buffer } " or " { $link update-buffer } ". However, performance may be worse when actual usage conflicts with declared usage."
+} ;
+
+HELP: buffer-access-mode
+{ $class-description "A " { $snippet "buffer-access-mode" } " value is passed to " { $link with-mapped-buffer } " to control access to the mapped address space." }
+{ $list
+{ { $link read-access } " permits the mapped address space only to be read from." }
+{ { $link write-access } " permits the mapped address space only to be written to." }
+{ { $link read-write-access } " permits full access to the mapped address space." }
+} ;
+
+HELP: buffer-kind
+{ $class-description { $snippet "buffer-kind" } " values tell the graphics driver what the primary application of a " { $link buffer } " object will be. Note that any buffer can be used for any purpose; however, performance may be improved if a buffer object is constructed as the same kind as its primary use case."
+{ $list
+{ "A " { $link vertex-buffer } " is used to store vertex attribute data to be rendered as part of a vertex array." }
+{ "An " { $link index-buffer } " is used to store indexes into a vertex array." }
+{ "A " { $link pixel-unpack-buffer } " is used as a source for updating texture image data." }
+{ "A " { $link pixel-pack-buffer } " is used as a destination for reading texture or framebuffer image data." }
+} }
+{ $notes "The " { $snippet "pixel-unpack-buffer" } " and " { $snippet "pixel-pack-buffer" } " kinds require OpenGL 2.1 or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+HELP: buffer-ptr
+{ $class-description "A " { $snippet "buffer-ptr" } " references a memory location inside a " { $link buffer } " object. " { $snippet "buffer-ptr" } "s are tuples with the following slots:"
+{ $list
+{ { $snippet "buffer" } " is the " { $link buffer } " object being referenced." }
+{ { $snippet "offset" } " is an integer offset from the beginning of the buffer." }
+} } ;
+
+HELP: buffer-upload-pattern
+{ $class-description { $snippet "buffer-upload-pattern" } " values aid the graphics driver in optimizing access to " { $link buffer } " objects by declaring the frequency with which the buffer will be supplied new data."
+{ $list
+{ { $link stream-upload } " declares that the buffer data will only be used a few times before being deallocated by " { $link dispose } " or replaced by " { $link allocate-buffer } "." }
+{ { $link static-upload } " declares that the buffer data will be provided once and accessed frequently without modification." }
+{ { $link dynamic-upload } " declares that the buffer data will be frequently modified." }
+}
+"A " { $snippet "buffer-upload-pattern" } " is only a declaration and does not actually control access to the underlying buffer data." } ;
+
+HELP: buffer-usage-pattern
+{ $class-description { $snippet "buffer-usage-pattern" } " values aid the graphics driver in optimizing access to " { $link buffer } " objects by declaring the primary provider and consumer of data for the buffer."
+{ $list
+{ { $link draw-usage } " declares that the buffer will be supplied with data from CPU memory and read from by the GPU for vertex or texture image data." }
+{ { $link read-usage } " declares that the buffer will be supplied with data from other GPU resources and read from primarily by the CPU." }
+{ { $link copy-usage } " declares that the buffer will both receive and supply data primarily for other GPU resources." }
+}
+"A " { $snippet "buffer-usage-pattern" } " is only a declaration and does not actually control access to the underlying buffer data." } ;
+
+{ buffer-kind buffer-upload-pattern buffer-usage-pattern } related-words
+
+HELP: byte-array>buffer
+{ $values
+ { "byte-array" byte-array }
+ { "upload" buffer-upload-pattern }
+ { "usage" buffer-usage-pattern }
+ { "kind" buffer-kind }
+ { "buffer" buffer }
+}
+{ $description "Allocates a new " { $link buffer } " object with the size and contents of " { $snippet "byte-array" } ". " { $snippet "upload" } ", " { $snippet "usage" } ", and " { $snippet "kind" } " provide hints to the implementation about the expected usage pattern of the buffer as documented in the " { $link buffer } " class documentation." } ;
+
+HELP: copy-buffer
+{ $values
+ { "to-buffer-ptr" buffer-ptr } { "from-buffer-ptr" buffer-ptr } { "size" integer }
+}
+{ $description "Instructs the GPU to asynchronously copy " { $snippet "size" } " bytes from " { $snippet "from-buffer-ptr" } " into " { $snippet "to-buffer-ptr" } "." }
+{ $notes "This word requires that the graphics context support OpenGL 3.1 or the " { $snippet "GL_ARB_copy_buffer" } " extension." } ;
+
+HELP: copy-usage
+{ $class-description "This " { $link buffer-usage-pattern } " declares that a " { $link buffer } " object will be primarily read from and written to by other GPU resources." } ;
+
+HELP: draw-usage
+{ $class-description "This " { $link buffer-usage-pattern } " declares that a " { $link buffer } " object will be primarily read from by the GPU and written to by the CPU." } ;
+
+HELP: dynamic-upload
+{ $class-description "This " { $link buffer-upload-pattern } " declares that a " { $link buffer } " object's data store will be updated frequently during its lifetime." } ;
+
+HELP: gpu-data-ptr
+{ $class-description "This class is a union of the " { $link c-ptr } " and " { $link buffer-ptr } " classes. It represents a value that can be supplied either from CPU or GPU memory." } ;
+
+HELP: index-buffer
+{ $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be to index vertex arrays." } ;
+
+HELP: pixel-pack-buffer
+{ $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be as a destination for receiving image data from textures or framebuffers." }
+{ $notes "This word requires OpenGL 2.1 or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+HELP: pixel-unpack-buffer
+{ $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be as a source for supplying image data to textures." }
+{ $notes "This word requires OpenGL 2.1 or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+HELP: read-access
+{ $class-description "This " { $link buffer-access-mode } " value requests read-only access when mapping a " { $link buffer } " object through " { $link with-mapped-buffer } "." } ;
+
+HELP: read-buffer
+{ $values
+ { "buffer-ptr" buffer-ptr } { "size" integer }
+ { "data" byte-array }
+}
+{ $description "Reads " { $snippet "size" } " bytes from " { $snippet "buffer" } " into a new " { $link byte-array } "." } ;
+
+HELP: read-usage
+{ $class-description "This " { $link buffer-usage-pattern } " declares that a " { $link buffer } " object will be primarily read from by the CPU and written to by the GPU." } ;
+
+{ copy-usage draw-usage read-usage } related-words
+
+HELP: read-write-access
+{ $class-description "This " { $link buffer-access-mode } " value requests full access when mapping a buffer object through " { $link with-mapped-buffer } "." } ;
+
+HELP: static-upload
+{ $class-description "This " { $link buffer-upload-pattern } " declares that a " { $link buffer } " object's data store will be read from frequently and modified infrequently." } ;
+
+HELP: stream-upload
+{ $var-description "This " { $link buffer-upload-pattern } " declares that a " { $link buffer } " object's data store will be used only a handful of times before being deallocated or replaced." } ;
+
+{ dynamic-upload static-upload stream-upload } related-words
+
+HELP: update-buffer
+{ $values
+ { "buffer-ptr" buffer-ptr } { "size" integer } { "data" { $maybe c-ptr } }
+}
+{ $description "Replaces " { $snippet "size" } " bytes of data in the " { $link buffer } " referenced by " { $snippet "buffer-ptr" } " with data from " { $snippet "data" } "." } ;
+
+HELP: vertex-buffer
+{ $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be to provide vertex attribute information to a vertex array." } ;
+
+{ index-buffer pixel-pack-buffer pixel-unpack-buffer vertex-buffer } related-words
+
+HELP: with-mapped-buffer
+{ $values
+ { "buffer" buffer } { "access" buffer-access-mode } { "quot" { $quotation "( alien -- )" } }
+}
+{ $description "Maps " { $snippet "buffer" } " into CPU address space with " { $snippet "access" } " for the dynamic extent of " { $snippet "quot" } ". " { $snippet "quot" } " is called with a pointer to the mapped memory on top of the stack." } ;
+
+{ allocate-buffer update-buffer read-buffer copy-buffer with-mapped-buffer } related-words
+
+HELP: write-access
+{ $class-description "This " { $link buffer-access-mode } " value requests write-only access when mapping a buffer object through " { $link with-mapped-buffer } "." } ;
+
+{ read-access read-write-access write-access } related-words
+
+ARTICLE: "gpu.buffers" "Buffer objects"
+"The " { $vocab-link "gpu.buffers" } " vocabulary provides words for creating, allocating, updating, and reading GPU data buffers."
+{ $subsection buffer }
+{ $subsection <buffer> }
+{ $subsection byte-array>buffer }
+"Declaring buffer usage:"
+{ $subsection buffer-kind }
+{ $subsection buffer-upload-pattern }
+{ $subsection buffer-usage-pattern }
+"Referencing buffer data:"
+{ $subsection buffer-ptr }
+"Manipulating buffer data:"
+{ $subsection allocate-buffer }
+{ $subsection update-buffer }
+{ $subsection read-buffer }
+{ $subsection copy-buffer }
+{ $subsection with-mapped-buffer }
+;
+
+ABOUT: "gpu.buffers"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien alien.c-types arrays byte-arrays
+combinators destructors gpu kernel locals math opengl opengl.gl
+ui.gadgets.worlds variants ;
+IN: gpu.buffers
+
+VARIANT: buffer-upload-pattern
+ stream-upload static-upload dynamic-upload ;
+
+VARIANT: buffer-usage-pattern
+ draw-usage read-usage copy-usage ;
+
+VARIANT: buffer-access-mode
+ read-access write-access read-write-access ;
+
+VARIANT: buffer-kind
+ vertex-buffer index-buffer
+ pixel-unpack-buffer pixel-pack-buffer ;
+
+TUPLE: buffer < gpu-object
+ { upload-pattern buffer-upload-pattern }
+ { usage-pattern buffer-usage-pattern }
+ { kind buffer-kind } ;
+
+<PRIVATE
+
+: gl-buffer-usage ( buffer -- usage )
+ [ upload-pattern>> ] [ usage-pattern>> ] bi 2array {
+ { { stream-upload draw-usage } [ GL_STREAM_DRAW ] }
+ { { stream-upload read-usage } [ GL_STREAM_READ ] }
+ { { stream-upload copy-usage } [ GL_STREAM_COPY ] }
+
+ { { static-upload draw-usage } [ GL_STATIC_DRAW ] }
+ { { static-upload read-usage } [ GL_STATIC_READ ] }
+ { { static-upload copy-usage } [ GL_STATIC_COPY ] }
+
+ { { dynamic-upload draw-usage } [ GL_DYNAMIC_DRAW ] }
+ { { dynamic-upload read-usage } [ GL_DYNAMIC_READ ] }
+ { { dynamic-upload copy-usage } [ GL_DYNAMIC_COPY ] }
+ } case ; inline
+
+: gl-access ( access -- gl-access )
+ {
+ { read-access [ GL_READ_ONLY ] }
+ { write-access [ GL_WRITE_ONLY ] }
+ { read-write-access [ GL_READ_WRITE ] }
+ } case ; inline
+
+: gl-target ( kind -- target )
+ {
+ { vertex-buffer [ GL_ARRAY_BUFFER ] }
+ { index-buffer [ GL_ELEMENT_ARRAY_BUFFER ] }
+ { pixel-unpack-buffer [ GL_PIXEL_UNPACK_BUFFER ] }
+ { pixel-pack-buffer [ GL_PIXEL_PACK_BUFFER ] }
+ } case ; inline
+
+PRIVATE>
+
+M: buffer dispose
+ [ [ delete-gl-buffer ] when* f ] change-handle drop ;
+
+TUPLE: buffer-ptr
+ { buffer buffer read-only }
+ { offset integer read-only } ;
+C: <buffer-ptr> buffer-ptr
+
+UNION: gpu-data-ptr buffer-ptr c-ptr ;
+
+:: allocate-buffer ( buffer size initial-data -- )
+ buffer kind>> gl-target :> target
+ target buffer handle>> glBindBuffer
+ target size initial-data buffer gl-buffer-usage glBufferData ;
+
+: <buffer> ( upload usage kind size initial-data -- buffer )
+ [ [ gen-gl-buffer ] 3dip buffer boa dup ] 2dip allocate-buffer
+ window-resource ;
+
+: byte-array>buffer ( byte-array upload usage kind -- buffer )
+ [ ] 3curry dip
+ [ byte-length ] [ ] bi <buffer> ;
+
+:: update-buffer ( buffer-ptr size data -- )
+ buffer-ptr buffer>> :> buffer
+ buffer kind>> gl-target :> target
+ target buffer handle>> glBindBuffer
+ target buffer-ptr offset>> size data glBufferSubData ;
+
+:: read-buffer ( buffer-ptr size -- data )
+ buffer-ptr buffer>> :> buffer
+ buffer kind>> gl-target :> target
+ size <byte-array> :> data
+ target buffer handle>> glBindBuffer
+ target buffer-ptr offset>> size data glGetBufferSubData
+ data ;
+
+:: copy-buffer ( to-buffer-ptr from-buffer-ptr size -- )
+ GL_COPY_WRITE_BUFFER to-buffer-ptr buffer>> glBindBuffer
+ GL_COPY_READ_BUFFER from-buffer-ptr buffer>> glBindBuffer
+
+ GL_COPY_READ_BUFFER GL_COPY_WRITE_BUFFER
+ from-buffer-ptr offset>> to-buffer-ptr offset>>
+ size glCopyBufferSubData ;
+
+:: with-mapped-buffer ( buffer access quot: ( alien -- ) -- )
+ buffer kind>> gl-target :> target
+
+ target buffer handle>> glBindBuffer
+ target access gl-access glMapBuffer
+
+ quot call
+
+ target glUnmapBuffer ; inline
+
+:: with-bound-buffer ( buffer target quot: ( -- ) -- )
+ target gl-target buffer glBindBuffer
+ quot call ; inline
+
+: with-buffer-ptr ( buffer-ptr target quot: ( c-ptr -- ) -- )
+ [ [ offset>> <alien> ] [ buffer>> handle>> ] bi ] 2dip
+ with-bound-buffer ; inline
+
+: with-gpu-data-ptr ( gpu-data-ptr target quot: ( c-ptr -- ) -- )
+ pick buffer-ptr?
+ [ with-buffer-ptr ]
+ [ [ gl-target 0 glBindBuffer ] dip call ] if ; inline
+
--- /dev/null
+Buffers in GPU memory
--- /dev/null
+Joe Groff
+Slava Pestov
--- /dev/null
+#version 110
+
+uniform mat4 mv_matrix, p_matrix;
+uniform vec4 color, ambient, diffuse;
+uniform float shininess;
+
+varying vec3 frag_normal;
+varying vec3 frag_light_direction;
+varying vec3 frag_eye_direction;
+
+float
+cel(float d)
+{
+ return smoothstep(0.25, 0.255, d) * 0.4 + smoothstep(0.695, 0.70, d) * 0.5;
+}
+
+vec4
+cel_light()
+{
+ vec3 normal = normalize(frag_normal),
+ light = normalize(frag_light_direction),
+ eye = normalize(frag_eye_direction),
+ reflection = reflect(light, normal);
+
+ float d = dot(light, normal) * 0.5 + 0.5;
+ float s = pow(max(dot(reflection, -eye), 0.0), shininess);
+
+ vec4 amb_diff = ambient + diffuse * vec4(vec3(cel(d)), 1.0);
+ vec4 spec = vec4(vec3(cel(s)), 0.0);
+
+ return amb_diff * color + spec;
+}
+
+void
+main()
+{
+ gl_FragData[0] = cel_light();
+ gl_FragData[1] = vec4(frag_normal, 0.0);
+}
--- /dev/null
+USING: accessors alien.c-types arrays 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.direct.float
+specialized-arrays.float specialized-vectors.uint splitting
+struct-vectors threads ui ui.gadgets ui.gadgets.worlds
+ui.pixel-formats ;
+IN: gpu.demos.bunny
+
+GLSL-SHADER-FILE: bunny-vertex-shader vertex-shader "bunny.v.glsl"
+GLSL-SHADER-FILE: bunny-fragment-shader fragment-shader "bunny.f.glsl"
+GLSL-PROGRAM: bunny-program
+ bunny-vertex-shader bunny-fragment-shader ;
+
+GLSL-SHADER-FILE: window-vertex-shader vertex-shader "window.v.glsl"
+
+GLSL-SHADER-FILE: sobel-fragment-shader fragment-shader "sobel.f.glsl"
+GLSL-PROGRAM: sobel-program
+ window-vertex-shader sobel-fragment-shader ;
+
+GLSL-SHADER-FILE: loading-fragment-shader fragment-shader "loading.f.glsl"
+GLSL-PROGRAM: loading-program
+ window-vertex-shader loading-fragment-shader ;
+
+TUPLE: bunny-state
+ vertexes
+ indexes
+ vertex-array
+ index-elements ;
+
+TUPLE: sobel-state
+ vertex-array
+ color-texture
+ normal-texture
+ depth-texture
+ framebuffer ;
+
+TUPLE: loading-state
+ vertex-array
+ texture ;
+
+TUPLE: bunny-world < wasd-world
+ bunny sobel loading ;
+
+VERTEX-FORMAT: bunny-vertex
+ { "vertex" float-components 3 f }
+ { f float-components 1 f }
+ { "normal" float-components 3 f }
+ { f float-components 1 f } ;
+VERTEX-STRUCT: bunny-vertex-struct bunny-vertex
+
+UNIFORM-TUPLE: bunny-uniforms < mvp-uniforms
+ { "light_position" float-uniform 3 }
+ { "color" float-uniform 4 }
+ { "ambient" float-uniform 4 }
+ { "diffuse" float-uniform 4 }
+ { "shininess" float-uniform 1 } ;
+
+UNIFORM-TUPLE: sobel-uniforms
+ { "texcoord_scale" float-uniform 2 }
+ { "color_texture" texture-uniform 1 }
+ { "normal_texture" texture-uniform 1 }
+ { "depth_texture" texture-uniform 1 }
+ { "line_color" float-uniform 4 } ;
+
+UNIFORM-TUPLE: loading-uniforms
+ { "texcoord_scale" float-uniform 2 }
+ { "loading_texture" texture-uniform 1 } ;
+
+: numbers ( str -- seq )
+ " " split [ string>number ] map sift ;
+
+: <bunny-vertex> ( vertex -- struct )
+ >float-array
+ "bunny-vertex-struct" <c-object>
+ [ set-bunny-vertex-struct-vertex ] keep ;
+
+: (parse-bunny-model) ( vs is -- vs is )
+ readln [
+ numbers {
+ { [ dup length 5 = ] [ 3 head <bunny-vertex> pick push ] }
+ { [ dup first 3 = ] [ rest over push-all ] }
+ [ drop ]
+ } cond (parse-bunny-model)
+ ] when* ;
+
+: parse-bunny-model ( -- vertexes indexes )
+ 100000 "bunny-vertex-struct" <struct-vector>
+ 100000 <uint-vector>
+ (parse-bunny-model) ;
+
+: normal ( vertexes -- normal )
+ [ [ second ] [ first ] bi v- ]
+ [ [ third ] [ first ] bi v- ] bi cross
+ vneg normalize ; inline
+
+: calc-bunny-normal ( vertexes indexes -- )
+ swap
+ [ [ nth bunny-vertex-struct-vertex 3 <direct-float-array> ] curry { } map-as normal ]
+ [
+ [
+ nth [ bunny-vertex-struct-normal 3 <direct-float-array> v+ ] keep
+ set-bunny-vertex-struct-normal
+ ] curry with each
+ ] 2bi ;
+
+: calc-bunny-normals ( vertexes indexes -- )
+ 3 <groups>
+ [ calc-bunny-normal ] with each ;
+
+: normalize-bunny-normals ( vertexes -- )
+ [
+ [ bunny-vertex-struct-normal 3 <direct-float-array> normalize ] keep
+ set-bunny-vertex-struct-normal
+ ] each ;
+
+: bunny-data ( filename -- vertexes indexes )
+ ascii [ parse-bunny-model ] with-file-reader
+ [ calc-bunny-normals ]
+ [ drop normalize-bunny-normals ]
+ [ ] 2tri ;
+
+: <bunny-buffers> ( vertexes indexes -- vertex-buffer index-buffer index-count )
+ [ underlying>> static-upload draw-usage vertex-buffer byte-array>buffer ]
+ [
+ [ underlying>> static-upload draw-usage index-buffer byte-array>buffer ]
+ [ length ] bi
+ ] bi* ;
+
+: bunny-model-path ( -- path ) "bun_zipper.ply" temp-file ;
+
+CONSTANT: bunny-model-url "http://factorcode.org/bun_zipper.ply"
+
+: download-bunny ( -- path )
+ bunny-model-path dup exists? [
+ bunny-model-url dup print flush
+ over download-to
+ ] unless ;
+
+: get-bunny-data ( bunny-state -- )
+ download-bunny bunny-data
+ [ >>vertexes ] [ >>indexes ] bi* drop ;
+
+: fill-bunny-state ( bunny-state -- )
+ dup [ vertexes>> ] [ indexes>> ] bi <bunny-buffers>
+ [ bunny-program <program-instance> bunny-vertex buffer>vertex-array >>vertex-array ]
+ [ 0 <buffer-ptr> ]
+ [ uint-indexes <index-elements> >>index-elements ] tri*
+ drop ;
+
+: <bunny-state> ( -- bunny-state )
+ bunny-state new
+ dup [ get-bunny-data ] curry "Downloading bunny model" spawn drop ;
+
+: bunny-loaded? ( bunny-state -- ? )
+ { [ vertexes>> ] [ indexes>> ] } 1&& ;
+
+: bunny-state-filled? ( bunny-state -- ? )
+ { [ vertex-array>> ] [ index-elements>> ] } 1&& ;
+
+: <sobel-state> ( window-vertex-buffer -- sobel-state )
+ sobel-state new
+ swap sobel-program <program-instance> window-vertex buffer>vertex-array >>vertex-array
+
+ RGBA half-components T{ texture-parameters
+ { wrap clamp-texcoord-to-edge }
+ { min-filter filter-linear }
+ { min-mipmap-filter f }
+ } <texture-2d> >>color-texture
+ RGBA half-components T{ texture-parameters
+ { wrap clamp-texcoord-to-edge }
+ { min-filter filter-linear }
+ { min-mipmap-filter f }
+ } <texture-2d> >>normal-texture
+ DEPTH u-24-components T{ texture-parameters
+ { wrap clamp-texcoord-to-edge }
+ { min-filter filter-linear }
+ { min-mipmap-filter f }
+ } <texture-2d> >>depth-texture
+
+ dup
+ [
+ [ color-texture>> 0 <texture-2d-attachment> ]
+ [ normal-texture>> 0 <texture-2d-attachment> ] bi 2array
+ ] [ depth-texture>> 0 <texture-2d-attachment> ] bi f { 1024 768 } <framebuffer> >>framebuffer ;
+
+: <loading-state> ( window-vertex-buffer -- loading-state )
+ loading-state new
+ swap
+ loading-program <program-instance> window-vertex buffer>vertex-array >>vertex-array
+
+ RGBA ubyte-components T{ texture-parameters
+ { wrap clamp-texcoord-to-edge }
+ { min-filter filter-linear }
+ { min-mipmap-filter f }
+ } <texture-2d>
+ dup 0 "vocab:gpu/demos/bunny/loading.tiff" load-image allocate-texture-image
+ >>texture ;
+
+BEFORE: bunny-world begin-world
+ init-gpu
+
+ { -0.2 0.13 0.1 } 1.1 0.2 set-wasd-view
+
+ <bunny-state> >>bunny
+ <window-vertex-buffer>
+ [ <sobel-state> >>sobel ]
+ [ <loading-state> >>loading ] bi
+ drop ;
+
+: <bunny-uniforms> ( world -- uniforms )
+ [ wasd-mv-matrix ] [ wasd-p-matrix ] bi
+ { -10000.0 10000.0 10000.0 } ! light position
+ { 0.6 0.5 0.5 1.0 } ! color
+ { 0.2 0.2 0.2 0.2 } ! ambient
+ { 0.8 0.8 0.8 0.8 } ! diffuse
+ 100.0 ! shininess
+ bunny-uniforms boa ;
+
+: draw-bunny ( world -- )
+ T{ depth-state { comparison cmp-less } } set-gpu-state*
+
+ [
+ sobel>> framebuffer>> {
+ { T{ color-attachment f 0 } { 0.15 0.15 0.15 1.0 } }
+ { T{ color-attachment f 1 } { 0.0 0.0 0.0 0.0 } }
+ { depth-attachment 1.0 }
+ } clear-framebuffer
+ ] [
+ render-set new
+ triangles-mode >>primitive-mode
+ { T{ color-attachment f 0 } T{ color-attachment f 1 } } >>output-attachments
+ swap {
+ [ <bunny-uniforms> >>uniforms ]
+ [ bunny>> vertex-array>> >>vertex-array ]
+ [ bunny>> index-elements>> >>indexes ]
+ [ sobel>> framebuffer>> >>framebuffer ]
+ } cleave
+ render
+ ] bi ;
+
+: <sobel-uniforms> ( sobel -- uniforms )
+ { 1.0 1.0 } swap
+ [ color-texture>> ] [ normal-texture>> ] [ depth-texture>> ] tri
+ { 0.1 0.0 0.1 1.0 } ! line_color
+ sobel-uniforms boa ;
+
+: draw-sobel ( world -- )
+ T{ depth-state { comparison f } } set-gpu-state*
+
+ render-set new
+ triangle-strip-mode >>primitive-mode
+ T{ index-range f 0 4 } >>indexes
+ swap sobel>>
+ [ <sobel-uniforms> >>uniforms ]
+ [ vertex-array>> >>vertex-array ] bi
+ render ;
+
+: draw-sobeled-bunny ( world -- )
+ [ draw-bunny ] [ draw-sobel ] bi ;
+
+: draw-loading ( world -- )
+ T{ depth-state { comparison f } } set-gpu-state*
+
+ render-set new
+ triangle-strip-mode >>primitive-mode
+ T{ index-range f 0 4 } >>indexes
+ swap loading>>
+ [ { 1.0 -1.0 } swap texture>> loading-uniforms boa >>uniforms ]
+ [ vertex-array>> >>vertex-array ] bi
+ render ;
+
+M: bunny-world draw-world*
+ dup bunny>>
+ dup bunny-loaded? [
+ dup bunny-state-filled? [ drop ] [ fill-bunny-state ] if
+ draw-sobeled-bunny
+ ] [ drop draw-loading ] if ;
+
+AFTER: bunny-world resize-world
+ [ sobel>> framebuffer>> ] [ dim>> ] bi resize-framebuffer ;
+
+M: bunny-world pref-dim* drop { 1024 768 } ;
+M: bunny-world tick-length drop 1000 30 /i ;
+M: bunny-world wasd-movement-speed drop 1/160. ;
+M: bunny-world wasd-near-plane drop 1/32. ;
+M: bunny-world wasd-far-plane drop 256.0 ;
+
+: bunny-window ( -- )
+ [
+ f T{ world-attributes
+ { world-class bunny-world }
+ { title "Bunny" }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ T{ depth-bits { value 24 } }
+ } }
+ { grab-input? t }
+ } open-window
+ ] with-ui ;
+
+MAIN: bunny-window
--- /dev/null
+#version 110
+
+uniform mat4 mv_matrix, p_matrix;
+uniform vec3 light_position;
+
+attribute vec3 vertex, normal;
+
+varying vec3 frag_normal;
+varying vec3 frag_light_direction;
+varying vec3 frag_eye_direction;
+
+void
+main()
+{
+ vec4 position = mv_matrix * vec4(vertex, 1.0);
+
+ gl_Position = p_matrix * position;
+ frag_normal = (mv_matrix * vec4(normal, 0.0)).xyz;
+ frag_light_direction = (mv_matrix * vec4(light_position, 1.0)).xyz - position.xyz;
+ frag_eye_direction = position.xyz;
+
+}
--- /dev/null
+#version 110
+
+uniform sampler2D loading_texture;
+
+varying vec2 texcoord;
+
+void
+main()
+{
+ gl_FragColor = texture2D(loading_texture, texcoord);
+}
--- /dev/null
+#version 110
+
+uniform sampler2D color_texture, normal_texture, depth_texture;
+uniform vec4 line_color;
+
+varying vec2 texcoord;
+
+const float sample_step = 1.0/512.0;
+const float depth_weight = 8.0;
+
+float
+border_factor(vec2 texcoord)
+{
+ float depth_samples[8];
+
+ depth_samples[0] = texture2D(depth_texture, texcoord + vec2(-sample_step, -sample_step)).x;
+ depth_samples[1] = texture2D(depth_texture, texcoord + vec2( 0, -sample_step)).x;
+ depth_samples[2] = texture2D(depth_texture, texcoord + vec2( sample_step, -sample_step)).x;
+
+ depth_samples[3] = texture2D(depth_texture, texcoord + vec2(-sample_step, 0 )).x;
+
+ depth_samples[4] = texture2D(depth_texture, texcoord + vec2( sample_step, 0 )).x;
+
+ depth_samples[5] = texture2D(depth_texture, texcoord + vec2(-sample_step, sample_step)).x;
+ depth_samples[6] = texture2D(depth_texture, texcoord + vec2( 0, sample_step)).x;
+ depth_samples[7] = texture2D(depth_texture, texcoord + vec2( sample_step, sample_step)).x;
+
+ float horizontal = 1.0 * depth_samples[0] + 2.0 * depth_samples[3] + 1.0 * depth_samples[5]
+ - 1.0 * depth_samples[2] - 2.0 * depth_samples[4] - 1.0 * depth_samples[7];
+
+ float vertical = 1.0 * depth_samples[0] + 2.0 * depth_samples[1] + 1.0 * depth_samples[2]
+ - 1.0 * depth_samples[5] - 2.0 * depth_samples[6] - 1.0 * depth_samples[7];
+
+ return depth_weight * sqrt(horizontal*horizontal + vertical*vertical);
+}
+
+void
+main()
+{
+ gl_FragColor = /*vec4(border_factor(texcoord));*/ mix(
+ texture2D(color_texture, texcoord),
+ line_color,
+ border_factor(texcoord)
+ );
+}
--- /dev/null
+Stanford Bunny with shader effects
--- /dev/null
+#version 110
+
+uniform vec2 texcoord_scale;
+
+attribute vec2 vertex;
+
+varying vec2 texcoord;
+
+void
+main()
+{
+ texcoord = (vertex * texcoord_scale) * vec2(0.5) + vec2(0.5);
+ gl_Position = vec4(vertex, 0.0, 1.0);
+}
--- /dev/null
+#version 110
+
+struct sphere
+{
+ vec3 center;
+ float radius;
+ vec4 color;
+};
+
+uniform sphere spheres[4];
+uniform float floor_height;
+uniform vec4 floor_color[2];
+uniform vec4 background_color;
+uniform vec3 light_direction;
+
+varying vec3 ray_origin, ray_direction;
+
+const float FAR_AWAY = 1.0e20;
+const vec4 reflection_color = vec4(1.0, 0.0, 1.0, 0.0);
+
+float sphere_intersect(sphere s, vec3 ro, vec3 rd)
+{
+ vec3 dist = (ro - s.center);
+
+ float b = dot(dist, normalize(rd));
+ float c = dot(dist, dist) - s.radius*s.radius;
+ float d = b * b - c;
+
+ return d > 0.0 ? -b - sqrt(d) : FAR_AWAY;
+}
+
+float floor_intersect(float height, vec3 ro, vec3 rd)
+{
+ return (height - ro.y) / rd.y;
+}
+
+void
+cast_ray(vec3 ro, vec3 rd, out sphere intersect_sphere, out bool intersect_floor, out float intersect_distance)
+{
+ intersect_floor = false;
+ intersect_distance = FAR_AWAY;
+
+ for (int i = 0; i < 4; ++i) {
+ float d = sphere_intersect(spheres[i], ro, rd);
+
+ if (d > 0.0 && d < intersect_distance) {
+ intersect_distance = d;
+ intersect_sphere = spheres[i];
+ }
+ }
+
+ if (intersect_distance >= FAR_AWAY) {
+ intersect_distance = floor_intersect(floor_height, ro, rd);
+ if (intersect_distance < 0.0)
+ intersect_distance = FAR_AWAY;
+ intersect_floor = intersect_distance < FAR_AWAY;
+ }
+}
+
+vec4 render_floor(vec3 at, float distance, bool shadowed)
+{
+ vec3 at2 = 0.125 * at;
+
+ float dropoff = exp(-0.005 * abs(distance)) * 0.8 + 0.2;
+ float fade = 0.5 * dropoff + 0.5;
+
+ vec4 color = fract((floor(at2.x) + floor(at2.z)) * 0.5) == 0.0
+ ? mix(floor_color[1], floor_color[0], fade)
+ : mix(floor_color[0], floor_color[1], fade);
+
+ float light = shadowed ? 0.2 : dropoff;
+
+ return color * light * dot(vec3(0.0, 1.0, 0.0), -light_direction);
+}
+
+vec4 sphere_color(vec4 color, vec3 normal, vec3 eye_ray, bool shadowed)
+{
+ float light = shadowed
+ ? 0.2
+ : max(dot(normal, -light_direction), 0.0) * 0.8 + 0.2;
+
+ float spec = shadowed
+ ? 0.0
+ : 0.3 * pow(max(dot(reflect(-light_direction, normal), eye_ray), 0.0), 100.0);
+
+ return color * light + vec4(spec);
+}
+
+bool reflection_p(vec4 color)
+{
+ vec4 difference = color - reflection_color;
+ return dot(difference, difference) == 0.0;
+}
+
+vec4 render_sphere(sphere s, vec3 at, vec3 eye_ray, bool shadowed)
+{
+ vec3 normal = normalize(at - s.center);
+
+ vec4 color;
+
+ if (reflection_p(s.color)) {
+ sphere reflect_sphere;
+ bool reflect_floor;
+ float reflect_distance;
+ vec3 reflect_direction = reflect(eye_ray, normal);
+
+ cast_ray(at, reflect_direction, reflect_sphere, reflect_floor, reflect_distance);
+
+ vec3 reflect_at = at + reflect_direction * reflect_distance;
+ if (reflect_floor)
+ color = render_floor(reflect_at, reflect_distance, false);
+ else if (reflect_distance < FAR_AWAY) {
+ vec3 reflect_normal = normalize(reflect_at - reflect_sphere.center);
+
+ color = sphere_color(reflect_sphere.color, reflect_normal, reflect_direction, false);
+ } else {
+ color = background_color;
+ }
+ } else
+ color = s.color;
+
+ return sphere_color(color, normal, eye_ray, shadowed);
+}
+
+void
+main()
+{
+ vec3 ray_direction_normalized = normalize(ray_direction);
+
+ sphere intersect_sphere;
+ bool intersect_floor;
+ float intersect_distance;
+
+ cast_ray(ray_origin, ray_direction_normalized, intersect_sphere, intersect_floor, intersect_distance);
+
+ vec3 at = ray_origin + ray_direction_normalized * intersect_distance;
+
+ sphere shadow_sphere;
+ bool shadow_floor;
+ float shadow_distance;
+
+ cast_ray(at - 0.0001 * light_direction, -light_direction, shadow_sphere, shadow_floor, shadow_distance);
+
+ bool shadowed = shadow_distance < FAR_AWAY;
+
+ if (intersect_floor)
+ gl_FragColor = render_floor(at, intersect_distance, shadowed);
+ else if (intersect_distance < FAR_AWAY)
+ gl_FragColor = render_sphere(intersect_sphere, at, ray_direction_normalized, shadowed);
+ else
+ gl_FragColor = background_color;
+}
+
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays game-loop game-worlds generalizations
+gpu gpu.render gpu.shaders gpu.util gpu.util.wasd kernel
+literals math math.matrices math.order math.vectors
+method-chains sequences ui ui.gadgets ui.gadgets.worlds
+ui.pixel-formats ;
+IN: gpu.demos.raytrace
+
+GLSL-SHADER-FILE: raytrace-vertex-shader vertex-shader "raytrace.v.glsl"
+GLSL-SHADER-FILE: raytrace-fragment-shader fragment-shader "raytrace.f.glsl"
+GLSL-PROGRAM: raytrace-program
+ raytrace-vertex-shader raytrace-fragment-shader ;
+
+UNIFORM-TUPLE: raytrace-uniforms
+ { "mv_inv_matrix" float-uniform { 4 4 } }
+ { "fov" float-uniform 2 }
+
+ { "spheres[0].center" float-uniform 3 }
+ { "spheres[0].radius" float-uniform 1 }
+ { "spheres[0].color" float-uniform 4 }
+
+ { "spheres[1].center" float-uniform 3 }
+ { "spheres[1].radius" float-uniform 1 }
+ { "spheres[1].color" float-uniform 4 }
+
+ { "spheres[2].center" float-uniform 3 }
+ { "spheres[2].radius" float-uniform 1 }
+ { "spheres[2].color" float-uniform 4 }
+
+ { "spheres[3].center" float-uniform 3 }
+ { "spheres[3].radius" float-uniform 1 }
+ { "spheres[3].color" float-uniform 4 }
+
+ { "floor_height" float-uniform 1 }
+ { "floor_color[0]" float-uniform 4 }
+ { "floor_color[1]" float-uniform 4 }
+ { "background_color" float-uniform 4 }
+ { "light_direction" float-uniform 3 } ;
+
+CONSTANT: reflection-color { 1.0 0.0 1.0 0.0 }
+
+TUPLE: sphere
+ { axis array }
+ { home array }
+ { dtheta float }
+ { radius float }
+ { color array }
+ { theta float initial: 0.0 } ;
+
+TUPLE: raytrace-world < wasd-world
+ fov
+ spheres
+ vertex-array ;
+
+: tick-sphere ( sphere -- )
+ dup dtheta>> [ + ] curry change-theta drop ;
+
+: sphere-center ( sphere -- center )
+ [ [ axis>> ] [ theta>> ] bi rotation-matrix4 ]
+ [ home>> ] bi m.v ;
+
+: <sphere-uniforms> ( world -- uniforms )
+ [ wasd-mv-inv-matrix ]
+ [ fov>> ]
+ [
+ spheres>>
+ [ [ sphere-center ] [ radius>> ] [ color>> ] tri 3array ] map
+ first4 [ first3 ] 4 napply
+ ] tri
+ -30.0 ! floor_height
+ { 1.0 0.0 0.0 1.0 } ! floor_color[0]
+ { 1.0 1.0 1.0 1.0 } ! floor_color[1]
+ { 0.15 0.15 1.0 1.0 } ! background_color
+ { 0.0 -1.0 -0.1 } ! light_direction
+ raytrace-uniforms boa ;
+
+CONSTANT: initial-spheres {
+ T{ sphere f { 0.0 1.0 0.0 } { 0.0 0.0 0.0 } 0.0 4.0 $ reflection-color }
+ T{ sphere f { 0.0 1.0 0.0 } { 7.0 0.0 0.0 } 0.02 1.0 { 1.0 0.0 0.0 1.0 } }
+ T{ sphere f { 0.0 0.0 -1.0 } { -9.0 0.0 0.0 } 0.03 1.0 { 0.0 1.0 0.0 1.0 } }
+ T{ sphere f { 1.0 0.0 0.0 } { 0.0 5.0 0.0 } 0.025 1.0 { 1.0 1.0 0.0 1.0 } }
+}
+
+BEFORE: raytrace-world begin-world
+ init-gpu
+ { -2.0 6.25 10.0 } 0.19 0.55 set-wasd-view
+ initial-spheres [ clone ] map >>spheres
+ raytrace-program <program-instance> <window-vertex-array> >>vertex-array
+ drop ;
+
+CONSTANT: fov 0.7
+
+AFTER: raytrace-world resize-world
+ dup dim>> dup first2 min >float v/n fov v*n >>fov drop ;
+
+AFTER: raytrace-world tick*
+ spheres>> [ tick-sphere ] each ;
+
+M: raytrace-world draw-world*
+ render-set new
+ triangle-strip-mode >>primitive-mode
+ T{ index-range f 0 4 } >>indexes
+ swap
+ [ <sphere-uniforms> >>uniforms ]
+ [ vertex-array>> >>vertex-array ] bi
+ render ;
+
+M: raytrace-world pref-dim* drop { 1024 768 } ;
+M: raytrace-world tick-length drop 1000 30 /i ;
+M: raytrace-world wasd-movement-speed drop 1/4. ;
+
+: raytrace-window ( -- )
+ [
+ f T{ world-attributes
+ { world-class raytrace-world }
+ { title "Raytracing" }
+ { pixel-format-attributes {
+ windowed
+ double-buffered
+ } }
+ { grab-input? t }
+ } open-window
+ ] with-ui ;
+
+MAIN: raytrace-window
--- /dev/null
+#version 110
+
+uniform mat4 mv_inv_matrix;
+uniform vec2 fov;
+
+attribute vec2 vertex;
+
+varying vec3 ray_origin, ray_direction;
+
+void
+main()
+{
+ gl_Position = vec4(vertex, 0.0, 1.0);
+ ray_direction = (mv_inv_matrix * vec4(fov * vertex, -1.0, 0.0)).xyz;
+ ray_origin = (mv_inv_matrix * vec4(0.0, 0.0, 0.0, 1.0)).xyz;
+}
+
--- /dev/null
+Real-time GPU-accelerated raytracing of reflective spheres
--- /dev/null
+Runnable demonstrations of the gpu library
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: alien byte-arrays gpu.buffers gpu.textures help.markup
+help.syntax images kernel math math.rectangles sequences ;
+IN: gpu.framebuffers
+
+HELP: <color-attachment>
+{ $values
+ { "index" integer }
+ { "color-attachment" color-attachment }
+}
+{ $description "Constructs an " { $link attachment-ref } " referencing the " { $snippet "index" } "th " { $snippet "color-attachment" } " of a framebuffer." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: <framebuffer-rect>
+{ $values
+ { "framebuffer" any-framebuffer } { "attachment" attachment-ref } { "rect" rect }
+ { "framebuffer-rect" framebuffer-rect }
+}
+{ $description "Constructs a " { $link framebuffer-rect } " tuple that references a rectangular region of " { $snippet "attachment" } " in " { $snippet "framebuffer" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+{ framebuffer-rect <framebuffer-rect> <full-framebuffer-rect> } related-words
+
+HELP: <framebuffer>
+{ $values
+ { "color-attachments" sequence } { "depth-attachment" framebuffer-attachment } { "stencil-attachment" framebuffer-attachment } { "dim" { $maybe sequence } }
+ { "framebuffer" framebuffer }
+}
+{ $description "Creates a new " { $link framebuffer } " object comprising the given set of " { $snippet "color-attachments" } ", " { $snippet "depth-attachment" } ", and " { $snippet "stencil-attachment" } ". If " { $snippet "dim" } " is not null, all of the attachments will be resized using " { $link resize-framebuffer } "; otherwise, each texture or renderbuffer being attached must have image memory allocated for the framebuffer creation to succeed." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions. If only the " { $snippet "GL_EXT_framebuffer_object" } " is available, all framebuffer attachments must have the same size, and all color attachments must have the same " { $link component-order } " and " { $link component-type } "." } ;
+
+HELP: <full-framebuffer-rect>
+{ $values
+ { "framebuffer" any-framebuffer } { "attachment" attachment-ref }
+ { "framebuffer-rect" framebuffer-rect }
+}
+{ $description "Constructs a " { $link framebuffer-rect } " tuple that spans the entire size of " { $snippet "attachment" } " in " { $snippet "framebuffer" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: <renderbuffer>
+{ $values
+ { "component-order" component-order } { "component-type" component-type } { "samples" { $maybe integer } } { "dim" { $maybe sequence } }
+ { "renderbuffer" renderbuffer }
+}
+{ $description "Creates a new " { $link renderbuffer } " object. If " { $snippet "samples" } " is not " { $link f } ", it specifies the multisampling level to use. If " { $snippet "dim" } " is not " { $link f } ", image memory of the given dimensions will be allocated for the renderbuffer; otherwise, memory will have to be allocated separately with " { $link allocate-renderbuffer } "." }
+{ $notes "Renderbuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions. Multisampled renderbuffers require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_multisample" } " extensions." } ;
+
+HELP: <system-attachment>
+{ $values
+ { "side" { $maybe framebuffer-attachment-side } } { "face" { $maybe framebuffer-attachment-face } }
+ { "system-attachment" system-attachment }
+}
+{ $description "Constructs an " { $link attachment-ref } " referencing a " { $link system-framebuffer } " color attachment." } ;
+
+HELP: <texture-1d-attachment>
+{ $values
+ { "texture" texture-data-target } { "level" integer }
+ { "texture-1d-attachment" texture-1d-attachment }
+}
+{ $description "Constructs a " { $link framebuffer-attachment } " to the " { $snippet "level" } "th level of detail of one-dimensional texture " { $snippet "texture" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: <texture-2d-attachment>
+{ $values
+ { "texture" texture-data-target } { "level" integer }
+ { "texture-2d-attachment" texture-2d-attachment }
+}
+{ $description "Constructs a " { $link framebuffer-attachment } " to the " { $snippet "level" } "th level of detail of two-dimensional texture " { $snippet "texture" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: <texture-3d-attachment>
+{ $values
+ { "texture" texture-data-target } { "z-offset" integer } { "level" integer }
+ { "texture-3d-attachment" texture-3d-attachment }
+}
+{ $description "Constructs a " { $link framebuffer-attachment } " to the " { $snippet "z-offset" } "th plane of the " { $snippet "level" } "th level of detail of three-dimensional texture " { $snippet "texture" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: <texture-layer-attachment>
+{ $values
+ { "texture" texture-data-target } { "layer" integer } { "level" integer }
+ { "texture-layer-attachment" texture-layer-attachment }
+}
+{ $description "Constructs a " { $link framebuffer-attachment } " to the " { $snippet "layer" } "th layer of the " { $snippet "level" } "th level of detail of three-dimensional texture or array texture " { $snippet "texture" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions. Array textures require OpenGL 3.0 or the " { $snippet "GL_EXT_texture_array" } " extension." } ;
+
+HELP: allocate-renderbuffer
+{ $values
+ { "renderbuffer" renderbuffer } { "dim" sequence }
+}
+{ $description "Allocates image memory for " { $snippet "renderbuffer" } " with dimension " { $snippet "dim" } "." }
+{ $notes "Renderbuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: any-framebuffer
+{ $class-description "This class is a union of the " { $link framebuffer } " class, which represents user-created framebuffer objects, and the " { $link system-framebuffer } ". Words which accept " { $snippet "any-framebuffer" } " can operate on either the system framebuffer or user framebuffers." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: attachment-ref
+{ $class-description "An " { $snippet "attachment-ref" } " value references a particular color, depth, or stencil attachment to a " { $link framebuffer } " object."
+{ $list
+{ { $link system-attachment } " references one or more of the color attachments to the " { $link system-framebuffer } "." }
+{ { $link color-attachment } " references one of the indexed color attachments to a user-created " { $link framebuffer } "." }
+{ { $link default-attachment } " references the back buffer of the " { $snippet "system-framebuffer" } " or the first color attachment of a user " { $snippet "framebuffer" } "." }
+{ { $link depth-attachment } " references the depth buffer attachment to any framebuffer." }
+{ { $link stencil-attachment } " references the stencil buffer attachment to any framebuffer." }
+} }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: back-face
+{ $class-description "Use this value in the " { $snippet "face" } " slot of a " { $link system-attachment } " reference to select the back face of a double-buffered " { $link system-framebuffer } "." } ;
+
+HELP: clear-framebuffer
+{ $values
+ { "framebuffer" any-framebuffer } { "alist" "a list of " { $link attachment-ref } "/value pairs" }
+}
+{ $description "Clears the active viewport area of the specified attachments to " { $snippet "framebuffer" } " to the associated values." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: clear-framebuffer-attachment
+{ $values
+ { "framebuffer" any-framebuffer } { "attachment-ref" attachment-ref } { "value" object }
+}
+{ $description "Clears the active viewport area of the given attachment to " { $snippet "framebuffer" } " to " { $snippet "value" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+{ clear-framebuffer clear-framebuffer-attachment } related-words
+
+HELP: color-attachment
+{ $class-description "This " { $link attachment-ref } " type references a color attachment to a user-created " { $link framebuffer } " object. The " { $snippet "index" } " slot of the tuple indicates the color attachment referenced. Color attachments to the " { $link system-framebuffer } " are referenced by the " { $link system-attachment } " type." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+{
+ color-attachment system-attachment default-attachment depth-attachment stencil-attachment
+ attachment-ref color-attachment-ref
+} related-words
+
+HELP: color-attachment-ref
+{ $class-description "A " { $snippet "color-attachment-ref" } " value references a particular color attachment to a " { $link framebuffer } " object."
+{ $list
+{ { $link system-attachment } " references one or more of the color attachments to the " { $link system-framebuffer } "." }
+{ { $link color-attachment } " references one of the indexed color attachments to a user-created " { $link framebuffer } "." }
+{ { $link default-attachment } " references the back buffer of the " { $snippet "system-framebuffer" } " or the first color attachment of a user " { $snippet "framebuffer" } "." }
+} }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: copy-framebuffer
+{ $values
+ { "to-fb-rect" framebuffer-rect } { "from-fb-rect" framebuffer-rect } { "depth?" boolean } { "stencil?" boolean } { "filter" texture-filter }
+}
+{ $description "Copies the rectangular region " { $snippet "from-fb-rect" } " to " { $snippet "to-fb-rect" } ". If " { $snippet "depth?" } " is true, depth values are also copied, and if " { $snippet "stencil?" } " is true, so are stencil values. If the rectangle sizes do not match, the region is scaled using nearest-neighbor or linear filtering based on " { $snippet "filter" } "." }
+{ $notes "This word requires OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_blit" } " extensions." } ;
+
+HELP: default-attachment
+{ $class-description "This " { $link attachment-ref } " references the back buffer of the " { $link system-framebuffer } " or the first color attachment of a user-created " { $link framebuffer } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: depth-attachment
+{ $class-description "This " { $link attachment-ref } " references the depth buffer attachment of a user-created " { $link framebuffer } " or the " { $link system-framebuffer } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: framebuffer
+{ $class-description "Objects of this class represent user-created framebuffer objects. These framebuffer objects provide an offscreen target for rendering operations and can send rendering output either to textures or to dedicated " { $link renderbuffer } "s. A framebuffer consists of a set of one or more color " { $link framebuffer-attachment } "s, an optional depth buffer " { $snippet "framebuffer-attachment" } ", and an optional stencil buffer " { $snippet "framebuffer-attachment" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: framebuffer-attachment
+{ $class-description "This class is a union of the " { $link renderbuffer } " and " { $link texture-attachment } " classes, either of which can function as an attachment to a user-created " { $link framebuffer } " object." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: framebuffer-attachment-at
+{ $values
+ { "framebuffer" framebuffer } { "attachment-ref" attachment-ref }
+ { "attachment" framebuffer-attachment }
+}
+{ $description "Returns the " { $link texture-attachment } " or " { $link renderbuffer } " referenced by " { $snippet "attachment-ref" } " in " { $snippet "framebuffer" } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: framebuffer-attachment-face
+{ $class-description "The values " { $link front-face } " and " { $link back-face } " select a face of a double-buffered " { $link system-framebuffer } " when stored in the " { $snippet "face" } " slot of a " { $link system-attachment } " reference." } ;
+
+HELP: framebuffer-attachment-side
+{ $class-description "The values " { $link left-side } " and " { $link right-side } " select a face of a stereoscopic " { $link system-framebuffer } " when stored in the " { $snippet "side" } " slot of a " { $link system-attachment } " reference." } ;
+
+HELP: framebuffer-rect
+{ $class-description "This tuple class references a rectangular subregion of a color attachment of a " { $link framebuffer } " object."
+{ $list
+{ { $snippet "framebuffer" } " references either a user-created " { $link framebuffer } " or the " { $link system-framebuffer } "." }
+{ { $snippet "attachment" } " is a " { $link color-attachment-ref } " referencing the color attachment of interest in the framebuffer." }
+{ { $snippet "rect" } " is a " { $link rect } " referencing the rectangular region of interest of the attachment." }
+} }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: front-face
+{ $class-description "Use this value in the " { $snippet "face" } " slot of a " { $link system-attachment } " reference to select the front face of a double-buffered " { $link system-framebuffer } "." } ;
+
+{ front-face back-face } related-words
+
+HELP: left-side
+{ $class-description "Use this value in the " { $snippet "side" } " slot of a " { $link system-attachment } " reference to select the left side of a stereoscopic " { $link system-framebuffer } "." } ;
+
+{ left-side right-side } related-words
+
+HELP: read-framebuffer
+{ $values
+ { "framebuffer-rect" framebuffer-rect }
+ { "byte-array" byte-array }
+}
+{ $description "Reads the rectangular region " { $snippet "framebuffer-rect" } " into a new " { $snippet "byte-array" } ". The format of the byte array is determined by the " { $link component-order } " and " { $link component-type } " of the associated " { $link framebuffer-attachment } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: read-framebuffer-image
+{ $values
+ { "framebuffer-rect" framebuffer-rect }
+ { "image" image }
+}
+{ $description "Reads the rectangular region " { $snippet "framebuffer-rect" } " into a new " { $snippet "image" } ". The format of the image is determined by the " { $link component-order } " and " { $link component-type } " of the associated " { $link framebuffer-attachment } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: read-framebuffer-to
+{ $values
+ { "framebuffer-rect" framebuffer-rect } { "gpu-data-ptr" gpu-data-ptr }
+}
+{ $description "Reads the rectangular region " { $snippet "framebuffer-rect" } " into " { $snippet "gpu-data-ptr" } ", which can reference either CPU memory (a " { $link byte-array } " or " { $link alien } ") or a GPU " { $link buffer-ptr } ". The format of the written data is determined by the " { $link component-order } " and " { $link component-type } " of the associated " { $link framebuffer-attachment } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions. Reading into a " { $snippet "buffer-ptr" } " requires OpenGL 2.1 or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+{ read-framebuffer read-framebuffer-image read-framebuffer-to } related-words
+
+HELP: renderbuffer
+{ $class-description "Objects of this type represent renderbuffer objects, two-dimensional image buffers that can serve as " { $link framebuffer-attachment } "s to user-created " { $link framebuffer } " objects." }
+{ $notes "Renderbuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+{ renderbuffer renderbuffer-dim allocate-renderbuffer <renderbuffer> } related-words
+{ framebuffer <framebuffer> resize-framebuffer } related-words
+
+HELP: renderbuffer-dim
+{ $values
+ { "renderbuffer" renderbuffer }
+ { "dim" sequence }
+}
+{ $description "Returns the dimensions of the allocated image memory for " { $snippet "renderbuffer" } "." }
+{ $notes "Renderbuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: resize-framebuffer
+{ $values
+ { "framebuffer" framebuffer } { "dim" sequence }
+}
+{ $description "Reallocates the image memory for all of the textures and renderbuffers bound to " { $snippet "framebuffer" } " to be of the given dimensions." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: right-side
+{ $class-description "Use this value in the " { $snippet "side" } " slot of a " { $link system-attachment } " reference to select the right side of a stereoscopic " { $link system-framebuffer } "." } ;
+
+HELP: stencil-attachment
+{ $class-description "This " { $link attachment-ref } " references the stencil buffer attachment of a user-created " { $link framebuffer } " or the " { $link system-framebuffer } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: system-attachment
+{ $class-description "This " { $link attachment-ref } " references one or more of the color attachments to the " { $link system-framebuffer } ". Depending on the window system pixel format for the window, up to four attachments may be available:"
+{ $list
+{ "If double buffering is available, there is a " { $link back-face } ", which holds the screen image as it is drawn, and a " { $link front-face } ", which holds the current contents of the screen. The two buffers get swapped when a scene is completely drawn." }
+{ "If stereoscopic rendering is available, there is a " { $link left-side } " and " { $link right-side } ", representing the left and right eye viewpoints of a 3D viewing apparatus." }
+}
+"To select a subset of these attachments, the " { $snippet "system-attachment" } " tuple type has two slots:"
+{ $list
+{ { $snippet "side" } " selects either the " { $snippet "left-side" } " or " { $snippet "right-side" } ", or both if set to " { $link f } "." }
+{ { $snippet "face" } " selects either the " { $snippet "back-face" } " or " { $snippet "front-face" } ", or both if set to " { $link f } "." }
+}
+"If stereo or double buffering are not available, then both sides or faces respectively will be equivalent. All attachments can be selected by setting both slots to " { $link f } ", both attachments of a side or face can be selected by setting a single slot, and a single attachment can be targeted by setting both slots." } ;
+
+HELP: system-framebuffer
+{ $class-description "This symbol represents the framebuffer supplied by the window system to store the contents of the window on screen. Since this framebuffer is managed by the window system, it cannot have its attachments modified or resized; however, it is still a valid target for rendering, copying via " { $link copy-framebuffer } ", clearing via " { $link clear-framebuffer } ", and reading via " { $link read-framebuffer } "." } ;
+
+HELP: texture-1d-attachment
+{ $class-description "This class references a single level of detail of a one-dimensional texture for use as a " { $link framebuffer-attachment } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: texture-2d-attachment
+{ $class-description "This class references a single level of detail of a two-dimensional texture for use as a " { $link framebuffer-attachment } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: texture-3d-attachment
+{ $class-description "This class references a single plane and level of detail of a three-dimensional texture for use as a " { $link framebuffer-attachment } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: texture-attachment
+{ $class-description "This class is a union of the " { $link texture-1d-attachment } ", " { $link texture-2d-attachment } ", " { $link texture-3d-attachment } ", and " { $link texture-layer-attachment } " classes, which select layers and levels of detail of " { $link texture } " objects to serve as " { $link framebuffer } " attachments." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions." } ;
+
+HELP: texture-layer-attachment
+{ $class-description "This class references a single layer and level of detail of a three-dimensional texture or array texture for use as a " { $link framebuffer-attachment } "." }
+{ $notes "User-created framebuffer objects require OpenGL 3.0 or one of the " { $snippet "GL_ARB_framebuffer_object" } " or " { $snippet "GL_EXT_framebuffer_object" } " extensions. Array textures require OpenGL 3.0 or the " { $snippet "GL_EXT_texture_array" } " extension." } ;
+
+{ texture-1d-attachment <texture-1d-attachment> } related-words
+{ texture-2d-attachment <texture-2d-attachment> } related-words
+{ texture-3d-attachment <texture-3d-attachment> } related-words
+{ texture-layer-attachment <texture-layer-attachment> } related-words
+
+ARTICLE: "gpu.framebuffers" "Framebuffer objects"
+"The " { $vocab-link "gpu.framebuffers" } " vocabulary provides words for creating, allocating, and reading from framebuffer objects. Framebuffer objects are used as rendering targets; the " { $link system-framebuffer } " is supplied by the window system and contains the contents of the window on screen. User-created " { $link framebuffer } " objects can also be created to direct rendering output to offscreen " { $link texture } "s or " { $link renderbuffer } "s."
+{ $subsection system-framebuffer }
+{ $subsection framebuffer }
+{ $subsection renderbuffer }
+"The contents of a framebuffer can be cleared to known values before rendering a scene:"
+{ $subsection clear-framebuffer }
+{ $subsection clear-framebuffer-attachment }
+"The image memory for a renderbuffer can be resized, or the full set of textures and renderbuffers attached to a framebuffer can be resized to the same dimensions together:"
+{ $subsection allocate-renderbuffer }
+{ $subsection resize-framebuffer }
+"Rectangular regions of framebuffers can be read into memory, read into GPU " { $link buffer } "s, and copied between framebuffers:"
+{ $subsection framebuffer-rect }
+{ $subsection attachment-ref }
+{ $subsection read-framebuffer }
+{ $subsection read-framebuffer-to }
+{ $subsection read-framebuffer-image }
+{ $subsection copy-framebuffer } ;
+
+ABOUT: "gpu.framebuffers"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien.c-types arrays byte-arrays combinators
+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 ;
+IN: gpu.framebuffers
+
+SINGLETON: system-framebuffer
+
+TUPLE: renderbuffer < gpu-object
+ { component-order component-order initial: RGBA }
+ { component-type component-type initial: ubyte-components }
+ { samples integer initial: 0 } ;
+
+<PRIVATE
+
+: get-framebuffer-int ( enum -- value )
+ GL_RENDERBUFFER swap 0 <int> [ glGetRenderbufferParameteriv ] keep *int ;
+
+PRIVATE>
+
+:: allocate-renderbuffer ( renderbuffer dim -- )
+ GL_RENDERBUFFER renderbuffer handle>> glBindRenderbuffer
+ GL_RENDERBUFFER
+ renderbuffer samples>> dup zero?
+ [ drop renderbuffer texture-gl-internal-format dim first2 glRenderbufferStorage ]
+ [ renderbuffer texture-gl-internal-format dim first2 glRenderbufferStorageMultisample ]
+ if ;
+
+:: renderbuffer-dim ( renderbuffer -- dim )
+ GL_RENDERBUFFER renderbuffer handle>> glBindRenderbuffer
+ GL_RENDERBUFFER_WIDTH get-framebuffer-int
+ GL_RENDERBUFFER_HEIGHT get-framebuffer-int 2array ;
+
+: <renderbuffer> ( component-order component-type samples dim -- renderbuffer )
+ [ [ gen-renderbuffer ] 3dip renderbuffer boa dup ] dip
+ [ allocate-renderbuffer ] [ drop ] if*
+ window-resource ;
+
+M: renderbuffer dispose
+ [ [ delete-renderbuffer ] when* f ] change-handle drop ;
+
+TUPLE: texture-1d-attachment
+ { texture texture-1d-data-target read-only initial: T{ texture-1d } }
+ { level integer read-only } ;
+
+C: <texture-1d-attachment> texture-1d-attachment
+
+TUPLE: texture-2d-attachment
+ { texture texture-2d-data-target read-only initial: T{ texture-2d } }
+ { level integer read-only } ;
+
+C: <texture-2d-attachment> texture-2d-attachment
+
+TUPLE: texture-3d-attachment
+ { texture texture-3d read-only initial: T{ texture-3d } }
+ { z-offset integer read-only }
+ { level integer read-only } ;
+
+C: <texture-3d-attachment> texture-3d-attachment
+
+TUPLE: texture-layer-attachment
+ { texture texture-3d-data-target read-only initial: T{ texture-3d } }
+ { layer integer read-only }
+ { level integer read-only } ;
+
+C: <texture-layer-attachment> texture-layer-attachment
+
+UNION: texture-attachment
+ texture-1d-attachment texture-2d-attachment texture-3d-attachment texture-layer-attachment ;
+
+M: texture-attachment dispose texture>> dispose ;
+
+UNION: framebuffer-attachment renderbuffer texture-attachment ;
+UNION: ?framebuffer-attachment framebuffer-attachment POSTPONE: f ;
+
+GENERIC: attachment-object ( attachment -- object )
+M: renderbuffer attachment-object ;
+M: texture-attachment attachment-object texture>> texture-object ;
+
+TUPLE: framebuffer < gpu-object
+ { color-attachments array read-only }
+ { depth-attachment ?framebuffer-attachment read-only initial: f }
+ { stencil-attachment ?framebuffer-attachment read-only initial: f } ;
+
+UNION: any-framebuffer system-framebuffer framebuffer ;
+
+VARIANT: framebuffer-attachment-side
+ left-side right-side ;
+
+VARIANT: framebuffer-attachment-face
+ back-face front-face ;
+
+UNION: ?framebuffer-attachment-side framebuffer-attachment-side POSTPONE: f ;
+UNION: ?framebuffer-attachment-face framebuffer-attachment-face POSTPONE: f ;
+
+VARIANT: color-attachment-ref
+ default-attachment
+ system-attachment: {
+ { side ?framebuffer-attachment-side initial: f }
+ { face ?framebuffer-attachment-face initial: back-face }
+ }
+ color-attachment: { { index integer } } ;
+
+VARIANT: non-color-attachment-ref
+ depth-attachment
+ stencil-attachment ;
+
+UNION: attachment-ref
+ color-attachment-ref
+ non-color-attachment-ref
+ POSTPONE: f ;
+
+TUPLE: framebuffer-rect
+ { framebuffer any-framebuffer read-only initial: system-framebuffer }
+ { attachment color-attachment-ref read-only initial: default-attachment }
+ { rect rect read-only } ;
+
+C: <framebuffer-rect> framebuffer-rect
+
+: framebuffer-attachment-at ( framebuffer attachment-ref -- attachment )
+ {
+ { default-attachment [ color-attachments>> first ] }
+ { color-attachment [ swap color-attachments>> nth ] }
+ { depth-attachment [ depth-attachment>> ] }
+ { stencil-attachment [ stencil-attachment>> ] }
+ } match ;
+
+<PRIVATE
+
+GENERIC: framebuffer-handle ( framebuffer -- handle )
+
+M: system-framebuffer framebuffer-handle drop 0 ;
+M: framebuffer framebuffer-handle handle>> ;
+
+GENERIC# allocate-framebuffer-attachment 1 ( framebuffer-attachment dim -- )
+
+M: texture-attachment allocate-framebuffer-attachment
+ [ [ texture>> ] [ level>> ] bi ] dip f allocate-texture ;
+M: renderbuffer allocate-framebuffer-attachment
+ allocate-renderbuffer ;
+
+GENERIC: framebuffer-attachment-dim ( framebuffer-attachment -- dim )
+
+M: texture-attachment framebuffer-attachment-dim
+ [ texture>> ] [ level>> ] bi texture-dim
+ dup number? [ 1 2array ] [ 2 head ] if ;
+
+M: renderbuffer framebuffer-attachment-dim
+ renderbuffer-dim ;
+
+: each-attachment ( framebuffer quot: ( attachment -- ) -- )
+ [ [ color-attachments>> ] dip each ]
+ [ swap depth-attachment>> [ swap call ] [ drop ] if* ]
+ [ swap stencil-attachment>> [ swap call ] [ drop ] if* ] 2tri ; inline
+
+: each-attachment-target ( framebuffer quot: ( attachment-target attachment -- ) -- )
+ [ [ color-attachments>> ] dip [ GL_COLOR_ATTACHMENT0 + swap ] prepose each-index ]
+ [ swap depth-attachment>> [ GL_DEPTH_ATTACHMENT spin call ] [ drop ] if* ]
+ [ swap stencil-attachment>> [ GL_STENCIL_ATTACHMENT spin call ] [ drop ] if* ] 2tri ; inline
+
+GENERIC: bind-framebuffer-attachment ( attachment-target attachment -- )
+
+M:: renderbuffer bind-framebuffer-attachment ( attachment-target renderbuffer -- )
+ GL_DRAW_FRAMEBUFFER attachment-target
+ GL_RENDERBUFFER renderbuffer handle>>
+ glFramebufferRenderbuffer ;
+
+M:: texture-1d-attachment bind-framebuffer-attachment ( attachment-target texture-attachment -- )
+ GL_DRAW_FRAMEBUFFER attachment-target
+ texture-attachment [ texture>> [ texture-data-gl-target ] [ texture-object handle>> ] bi ] [ level>> ] bi
+ glFramebufferTexture1D ;
+
+M:: texture-2d-attachment bind-framebuffer-attachment ( attachment-target texture-attachment -- )
+ GL_DRAW_FRAMEBUFFER attachment-target
+ texture-attachment [ texture>> [ texture-data-gl-target ] [ texture-object handle>> ] bi ] [ level>> ] bi
+ glFramebufferTexture2D ;
+
+M:: texture-3d-attachment bind-framebuffer-attachment ( attachment-target texture-attachment -- )
+ GL_DRAW_FRAMEBUFFER attachment-target
+ texture-attachment
+ [ texture>> [ texture-data-gl-target ] [ texture-object handle>> ] bi ]
+ [ level>> ] [ z-offset>> ] tri
+ glFramebufferTexture3D ;
+
+M:: texture-layer-attachment bind-framebuffer-attachment ( attachment-target texture-attachment -- )
+ GL_DRAW_FRAMEBUFFER attachment-target
+ texture-attachment
+ [ texture>> texture-object handle>> ]
+ [ level>> ] [ layer>> ] tri
+ glFramebufferTextureLayer ;
+
+GENERIC: (default-gl-attachment) ( framebuffer -- gl-attachment )
+GENERIC: (default-attachment-type) ( framebuffer -- type )
+GENERIC: (default-attachment-image-type) ( framebuffer -- order type )
+
+M: system-framebuffer (default-gl-attachment)
+ drop GL_BACK ;
+M: framebuffer (default-gl-attachment)
+ drop GL_COLOR_ATTACHMENT0 ;
+
+SYMBOLS: float-type int-type uint-type ;
+
+: (color-attachment-type) ( framebuffer index -- type )
+ swap color-attachments>> nth attachment-object component-type>> {
+ { [ dup signed-unnormalized-integer-components? ] [ drop int-type ] }
+ { [ dup unsigned-unnormalized-integer-components? ] [ drop uint-type ] }
+ [ drop float-type ]
+ } cond ;
+
+M: system-framebuffer (default-attachment-type)
+ drop float-type ;
+M: framebuffer (default-attachment-type)
+ 0 (color-attachment-type) ;
+
+M: system-framebuffer (default-attachment-image-type) ( framebuffer -- order type )
+ drop RGBA ubyte-components ;
+M: framebuffer (default-attachment-image-type) ( framebuffer -- order type )
+ color-attachments>> first attachment-object
+ [ component-order>> ] [ component-type>> ] bi ;
+
+: gl-system-attachment ( side face -- attachment )
+ 2array {
+ { { f f } [ GL_FRONT_AND_BACK ] }
+ { { f front-face } [ GL_FRONT ] }
+ { { f back-face } [ GL_BACK ] }
+ { { left-side f } [ GL_LEFT ] }
+ { { left-side front-face } [ GL_FRONT_LEFT ] }
+ { { left-side back-face } [ GL_BACK_LEFT ] }
+ { { right-side f } [ GL_RIGHT ] }
+ { { right-side front-face } [ GL_FRONT_RIGHT ] }
+ { { right-side back-face } [ GL_BACK_RIGHT ] }
+ } case ;
+
+: gl-attachment ( framebuffer attachment-ref -- gl-attachment )
+ [ {
+ { depth-attachment [ GL_DEPTH_ATTACHMENT ] }
+ { stencil-attachment [ GL_STENCIL_ATTACHMENT ] }
+ { color-attachment [ GL_COLOR_ATTACHMENT0 + ] }
+ { system-attachment [ gl-system-attachment ] }
+ { default-attachment [ dup (default-gl-attachment) ] }
+ } match ] [ GL_NONE ] if* nip ;
+
+: color-attachment-image-type ( framebuffer attachment-ref -- order type )
+ {
+ { color-attachment [
+ swap color-attachments>> nth
+ attachment-object [ component-order>> ] [ component-type>> ] bi
+ ] }
+ { system-attachment [ 3drop RGBA ubyte-components ] }
+ { default-attachment [ (default-attachment-image-type) ] }
+ } match ;
+
+: framebuffer-rect-image-type ( framebuffer-rect -- order type )
+ [ framebuffer>> ] [ attachment>> ] bi color-attachment-image-type ;
+
+HOOK: (clear-integer-color-attachment) gpu-api ( type value -- )
+
+M: opengl-2 (clear-integer-color-attachment)
+ 4 0 pad-tail first4
+ swap {
+ { int-type [ glClearColorIiEXT ] }
+ { uint-type [ glClearColorIuiEXT ] }
+ } case GL_COLOR_BUFFER_BIT glClear ;
+
+M: opengl-3 (clear-integer-color-attachment)
+ [ GL_COLOR 0 ] dip 4 0 pad-tail
+ swap {
+ { int-type [ >int-array glClearBufferiv ] }
+ { uint-type [ >uint-array glClearBufferuiv ] }
+ } case ;
+
+:: (clear-color-attachment) ( type attachment value -- )
+ attachment glDrawBuffer
+ type float-type =
+ [ value 4 value last pad-tail first4 glClearColor GL_COLOR_BUFFER_BIT glClear ]
+ [ type value (clear-integer-color-attachment) ] if ;
+
+: framebuffer-rect-size ( framebuffer-rect -- size )
+ [ rect>> dim>> product ]
+ [ framebuffer-rect-image-type (bytes-per-pixel) ] bi * ;
+
+PRIVATE>
+
+: <full-framebuffer-rect> ( framebuffer attachment -- framebuffer-rect )
+ 2dup framebuffer-attachment-at
+ { 0 0 } swap framebuffer-attachment-dim <rect>
+ <framebuffer-rect> ;
+
+: resize-framebuffer ( framebuffer dim -- )
+ [ allocate-framebuffer-attachment ] curry each-attachment ;
+
+:: attach-framebuffer-attachments ( framebuffer -- )
+ GL_DRAW_FRAMEBUFFER framebuffer handle>> glBindFramebuffer
+ framebuffer [ bind-framebuffer-attachment ] each-attachment-target ;
+
+M: framebuffer dispose
+ [ [ delete-framebuffer ] when* f ] change-handle drop ;
+
+: dispose-framebuffer-attachments ( framebuffer -- )
+ [ [ dispose ] when* ] each-attachment ;
+
+: <framebuffer> ( color-attachments depth-attachment stencil-attachment dim -- framebuffer )
+ [ [ 0 ] 3dip framebuffer boa dup ] dip
+ [ resize-framebuffer ] [ drop ] if*
+ gen-framebuffer >>handle
+ dup attach-framebuffer-attachments
+ window-resource ;
+
+:: clear-framebuffer-attachment ( framebuffer attachment-ref value -- )
+ GL_DRAW_FRAMEBUFFER framebuffer framebuffer-handle glBindFramebuffer
+ attachment-ref {
+ { system-attachment [| side face |
+ float-type
+ side face gl-system-attachment
+ value (clear-color-attachment)
+ ] }
+ { color-attachment [| i |
+ framebuffer i (color-attachment-type)
+ GL_COLOR_ATTACHMENT0 i +
+ value (clear-color-attachment)
+ ] }
+ { default-attachment [
+ framebuffer [ (default-attachment-type) ] [ (default-gl-attachment) ] bi
+ value (clear-color-attachment)
+ ] }
+ { depth-attachment [ value glClearDepth GL_DEPTH_BUFFER_BIT glClear ] }
+ { stencil-attachment [ value glClearStencil GL_STENCIL_BUFFER_BIT glClear ] }
+ } match ;
+
+: clear-framebuffer ( framebuffer alist -- )
+ [ first2 clear-framebuffer-attachment ] with each ;
+
+:: read-framebuffer-to ( framebuffer-rect gpu-data-ptr -- )
+ GL_READ_FRAMEBUFFER framebuffer-rect framebuffer>> framebuffer-handle glBindFramebuffer
+ framebuffer-rect [ framebuffer>> ] [ attachment>> ] bi gl-attachment glReadBuffer
+ framebuffer-rect rect>> [ loc>> first2 ] [ dim>> first2 ] bi
+ framebuffer-rect framebuffer-rect-image-type image-data-format
+ gpu-data-ptr pixel-pack-buffer [ glReadPixels ] with-gpu-data-ptr ;
+
+: read-framebuffer ( framebuffer-rect -- byte-array )
+ dup framebuffer-rect-size <byte-array> [ read-framebuffer-to ] keep ;
+
+: read-framebuffer-image ( framebuffer-rect -- image )
+ [ <image> ] dip {
+ [ rect>> dim>> >>dim ]
+ [
+ framebuffer-rect-image-type
+ [ >>component-order ] [ >>component-type ] bi*
+ ]
+ [ read-framebuffer >>bitmap ]
+ } cleave ;
+
+:: copy-framebuffer ( to-fb-rect from-fb-rect depth? stencil? filter -- )
+ GL_DRAW_FRAMEBUFFER to-fb-rect framebuffer>> framebuffer-handle glBindFramebuffer
+ to-fb-rect [ framebuffer>> ] [ attachment>> ] bi gl-attachment glDrawBuffer
+ GL_READ_FRAMEBUFFER from-fb-rect framebuffer>> framebuffer-handle glBindFramebuffer
+ from-fb-rect [ framebuffer>> ] [ attachment>> ] bi gl-attachment glReadBuffer
+ to-fb-rect attachment>> [ GL_COLOR_BUFFER_BIT ] [ 0 ] if
+ depth? [ GL_DEPTH_BUFFER_BIT ] [ 0 ] if bitor
+ stencil? [ GL_STENCIL_BUFFER_BIT ] [ 0 ] if bitor :> mask
+
+ from-fb-rect rect>> rect-extent [ first2 ] bi@
+ to-fb-rect rect>> rect-extent [ first2 ] bi@
+ mask filter gl-mag-filter glBlitFramebuffer ;
+
--- /dev/null
+Render targets for GPU operations
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: help.markup help.syntax ui.gadgets.worlds ;
+IN: gpu
+
+HELP: finish-gpu
+{ $description "Waits for all outstanding GPU commands in the current graphics context to complete." } ;
+
+HELP: flush-gpu
+{ $description "Forces the execution of all outstanding GPU commands in the current graphics context." }
+{ $notes { $snippet "flush-gpu" } " does not wait for execution to finish. For that, use " { $link finish-gpu } "." } ;
+
+{ finish-gpu flush-gpu } related-words
+
+HELP: gpu-object
+{ $class-description "Parent class of all GPU resources." } ;
+
+HELP: init-gpu
+{ $description "Initializes the current graphics context for use with the " { $snippet "gpu" } " library. This should be the first thing called in a world's " { $link begin-world } " method." } ;
+
+HELP: reset-gpu
+{ $description "Clears all framebuffer, GPU buffer, shader, and vertex array bindings. Call this before directly calling OpenGL functions after using " { $snippet "gpu" } " functions." } ;
+
+ARTICLE: "gpu" "Graphics context management"
+"Preparing the GPU library:"
+{ $subsection init-gpu }
+"Forcing execution of queued commands:"
+{ $subsection flush-gpu }
+{ $subsection finish-gpu }
+"Resetting OpenGL state:"
+{ $subsection reset-gpu } ;
+
+ARTICLE: "gpu-summary" "GPU-accelerated rendering"
+"The " { $vocab-link "gpu" } " library is a set of vocabularies that work together to provide a convenient interface to creating, managing, and using GPU resources."
+{ $subsection "gpu" }
+{ $subsection "gpu.state" }
+{ $subsection "gpu.buffers" }
+{ $subsection "gpu.textures" }
+{ $subsection "gpu.framebuffers" }
+{ $subsection "gpu.shaders" }
+{ $subsection "gpu.render" }
+"The library is built on top of the OpenGL API, but it aims to be complete enough that raw OpenGL calls are never needed. OpenGL 2.0 with the vertex array object extension (" { $snippet "GL_APPLE_vertex_array_object" } " or " { $snippet "GL_ARB_vertex_array_object" } ") is required. Some features require later OpenGL versions or additional extensions; these requirements are documented alongside individual words. To make full use of the library, an OpenGL 3.1 or later implementation is recommended." ;
+
+ABOUT: "gpu-summary"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: kernel namespaces opengl.capabilities opengl.gl variants ;
+IN: gpu
+
+TUPLE: gpu-object < identity-tuple handle ;
+
+<PRIVATE
+
+VARIANT: gpu-api
+ opengl-2 opengl-3 ;
+
+: set-gpu-api ( -- )
+ "2.0" require-gl-version
+ "3.0" has-gl-version? opengl-3 opengl-2 ? gpu-api set-global ;
+
+HOOK: init-gpu-api gpu-api ( -- )
+
+M: opengl-2 init-gpu-api
+ GL_POINT_SPRITE glEnable ;
+M: opengl-3 init-gpu-api
+ ;
+
+PRIVATE>
+
+: init-gpu ( -- )
+ set-gpu-api
+ init-gpu-api ;
+
+: reset-gpu ( -- )
+ "3.0" { { "GL_APPLE_vertex_array_object" "GL_ARB_vertex_array_object" } }
+ has-gl-version-or-extensions?
+ [ 0 glBindVertexArray ] when
+
+ "3.0" { { "GL_EXT_framebuffer_object" "GL_ARB_framebuffer_object" } }
+ has-gl-version-or-extensions? [
+ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer
+ GL_READ_FRAMEBUFFER 0 glBindFramebuffer
+ GL_RENDERBUFFER 0 glBindRenderbuffer
+ ] when
+
+ "1.5" { "GL_ARB_vertex_buffer_object" }
+ has-gl-version-or-extensions? [
+ GL_ARRAY_BUFFER 0 glBindBuffer
+ GL_ELEMENT_ARRAY_BUFFER 0 glBindBuffer
+ ] when
+
+ "2.1" { "GL_ARB_pixel_buffer_object" }
+ has-gl-version-or-extensions? [
+ GL_PIXEL_PACK_BUFFER 0 glBindBuffer
+ GL_PIXEL_UNPACK_BUFFER 0 glBindBuffer
+ ] when
+
+ "2.0" { "GL_ARB_shader_objects" }
+ has-gl-version-or-extensions?
+ [ 0 glUseProgram ] when ;
+
+: flush-gpu ( -- )
+ glFlush ;
+
+: finish-gpu ( -- )
+ glFinish ;
--- /dev/null
+! (c)2009 Joe Groff bsd license
+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 ;
+IN: gpu.render
+
+HELP: <index-elements>
+{ $values
+ { "ptr" gpu-data-ptr } { "count" integer } { "index-type" index-type }
+ { "index-elements" index-elements }
+}
+{ $description "Constructs an " { $link index-elements } " tuple." } ;
+
+HELP: <index-range>
+{ $values
+ { "start" integer } { "count" integer }
+ { "index-range" index-range }
+}
+{ $description "Constructs an " { $link index-range } " tuple." } ;
+
+HELP: <multi-index-elements>
+{ $values
+ { "buffer" { $maybe buffer } } { "ptrs" "an " { $link uint-array } " or " { $link void*-array } } { "counts" uint-array } { "index-type" index-type }
+ { "multi-index-elements" multi-index-elements }
+}
+{ $description "Constructs a " { $link multi-index-elements } " tuple." } ;
+
+HELP: <multi-index-range>
+{ $values
+ { "starts" uint-array } { "counts" uint-array }
+ { "multi-index-range" multi-index-range }
+}
+{ $description "Constructs a " { $link multi-index-range } " tuple." } ;
+
+HELP: <vertex-array>
+{ $values
+ { "program-instance" program-instance } { "vertex-formats" "a list of " { $link buffer-ptr } "/" { $link vertex-format } " pairs" }
+ { "vertex-array" vertex-array }
+}
+{ $description "Creates a new " { $link vertex-array } " to feed data to " { $snippet "program-instance" } " from the set of " { $link buffer } "s specified in " { $snippet "vertex-formats" } "." } ;
+
+HELP: UNIFORM-TUPLE:
+{ $syntax <" UNIFORM-TUPLE: class-name
+ { "slot" uniform-type dimension }
+ { "slot" uniform-type dimension }
+ ...
+ { "slot" uniform-type dimension } ; "> }
+{ $description "Defines a new " { $link uniform-tuple } " class. Tuples of the new class can be used as the " { $snippet "uniforms" } " slot of a " { $link render-set } " in order to set the uniform parameters of the active shader program. The " { $link uniform-type } " of each slot defines the component type, and the " { $snippet "dimension" } " defines the vector or matrix dimensions; for example, a slot " { $snippet "{ \"foo\" float-uniform { 2 2 } }" } " will define a slot " { $snippet "foo" } " as a 2x2 matrix of floats."
+$nl
+"Uniform parameters are passed from Factor to the shader program through the uniform tuple as follows:"
+{ $list
+{ { $link int-uniform } "s and " { $link uint-uniform } "s take their values from Factor " { $link integer } "s." }
+{ { $link float-uniform } "s take their values from Factor " { $link float } "s." }
+{ { $link bool-uniform } "s take their values from Factor " { $link boolean } "s." }
+{ { $link texture-uniform } "s take their values from " { $link texture } " objects." }
+{ "Vector uniforms are passed as Factor " { $link sequence } "s of the corresponding component type." }
+{ "Matrix uniforms are passed as row-major Factor " { $link sequence } "s of sequences of the corresponding component type." } }
+"A value of a uniform tuple type is a standard Factor tuple. Uniform tuples are constructed with " { $link new } " or " { $link boa } ", and values are placed inside them using standard slot accessors."
+} ;
+
+HELP: VERTEX-FORMAT:
+{ $syntax <" VERTEX-FORMAT: format-name
+ { "attribute"/f component-type dimension normalize? }
+ { "attribute"/f component-type dimension normalize? }
+ ...
+ { "attribute"/f component-type dimension normalize? } ; "> }
+{ $description "Defines a new binary " { $link vertex-format } " for structuring vertex data stored in " { $link buffer } "s. Each " { $snippet "attribute" } " name either corresponds to an input parameter of a vertex shader, or is " { $link f } " to include padding in the vertex format. The " { $link component-type } " determines the format of the components, and the " { $snippet "dimension" } " determines the number of components. If the " { $snippet "component-type" } " is an integer type and " { $snippet "normalize?" } " is true, the component values will be scaled to the range 0.0 to 1.0 when fed to the vertex shader; otherwise, they will be cast to floats retaining their integral values." } ;
+
+HELP: VERTEX-STRUCT:
+{ $syntax <" VERTEX-STRUCT: struct-name format-name "> }
+{ $description "Defines a struct C type (like " { $link POSTPONE: C-STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ;
+
+HELP: bool-uniform
+{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "bool" } "s." } ;
+
+HELP: buffer>vertex-array
+{ $values
+ { "vertex-buffer" buffer } { "program-instance" program-instance } { "format" vertex-format }
+ { "vertex-array" vertex-array }
+}
+{ $description "Creates a new " { $link vertex-array } " from the entire contents of a single " { $link buffer } " in a single " { $link vertex-format } " for use with " { $snippet "program-instance" } "." } ;
+
+{ vertex-array <vertex-array> buffer>vertex-array } related-words
+
+HELP: define-uniform-tuple
+{ $values
+ { "class" class } { "superclass" class } { "uniforms" sequence }
+}
+{ $description "Defines a new " { $link uniform-tuple } " as a subclass of " { $snippet "superclass" } " with the slots specified by the " { $link uniform } " tuple values in " { $snippet "uniforms" } ". The runtime equivalent of " { $link POSTPONE: UNIFORM-TUPLE: } ". This word must be called inside a compilation unit." } ;
+
+HELP: define-vertex-format
+{ $values
+ { "class" class } { "vertex-attributes" sequence }
+}
+{ $description "Defines a new " { $link vertex-format } " with the binary format specified by the " { $link vertex-attribute } " tuple values in " { $snippet "vertex-attributes" } ". The runtime equivalent of " { $link POSTPONE: VERTEX-FORMAT: } ". This word must be called inside a compilation unit." } ;
+
+HELP: define-vertex-struct
+{ $values
+ { "struct-name" string } { "vertex-format" vertex-format }
+}
+{ $description "Defines a new struct C type from a " { $link vertex-format } ". The runtime equivalent of " { $link POSTPONE: VERTEX-STRUCT: } ". This word must be called inside a compilation unit." } ;
+
+HELP: float-uniform
+{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "float" } "s." } ;
+
+{ bool-uniform int-uniform float-uniform texture-uniform } related-words
+
+{ index-elements index-range multi-index-elements multi-index-range } related-words
+
+HELP: index-elements
+{ $class-description "Objects of this tuple class can be passed as the " { $snippet "indexes" } " slot of a " { $link render-set } " to instruct " { $link render } " to assemble primitives from the active " { $link vertex-array } " by using an array of indexes in CPU or GPU memory."
+{ $list
+{ "The " { $snippet "ptr" } " slot contains a " { $link byte-array } ", " { $link alien } ", or " { $link buffer-ptr } " value referencing the beginning of the index array." }
+{ "The " { $snippet "count" } " slot contains an " { $link integer } " value specifying the number of indexes to supply from the array." }
+{ "The " { $snippet "index-type" } " slot contains an " { $link index-type } " value specifying whether the array consists of " { $link ubyte-indexes } ", " { $link ushort-indexes } ", or " { $link uint-indexes } "." }
+} } ;
+
+HELP: index-range
+{ $class-description "Objects of this tuple class can be passed as the " { $snippet "indexes" } " slot of a " { $link render-set } " to instruct " { $link render } " to assemble primitives sequentially from a slice of the active " { $link vertex-array } "."
+{ $list
+{ "The " { $snippet "start" } " slot contains an " { $link integer } " value indicating the first element of the array to draw." }
+{ "The " { $snippet "count" } " slot contains an " { $link integer } " value indicating the number of elements to draw." }
+} } ;
+
+HELP: index-type
+{ $class-description "The " { $snippet "index-type" } " slot of an " { $link index-elements } " or " { $link multi-index-elements } " tuple indicates the type of the index array's elements: one-byte " { $link ubyte-indexes } ", two-byte " { $link ushort-indexes } ", or four-byte " { $link uint-indexes } "." } ;
+
+{ index-type ubyte-indexes ushort-indexes uint-indexes } related-words
+
+HELP: int-uniform
+{ $class-description "This " { $link uniform-type } " value indicates a uniform parameter whose components are " { $snippet "int" } "s." } ;
+
+HELP: invalid-uniform-type
+{ $values
+ { "uniform" uniform }
+}
+{ $description "Throws an error indicating that a slot of a " { $link uniform-tuple } " has been declared to have an invalid type." } ;
+
+HELP: lines-mode
+{ $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to assemble a line from each pair of indexed vertex array elements." } ;
+
+HELP: line-loop-mode
+{ $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to assemble a connected loop of lines from each consecutive pair of indexed vertex array elements, adding another line to close the last and first elements." } ;
+
+HELP: line-strip-mode
+{ $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to assemble a connected strip of lines from each consecutive pair of indexed vertex array elements." } ;
+
+HELP: multi-index-elements
+{ $class-description "Objects of this tuple class can be passed as the " { $snippet "indexes" } " slot of a non-instanced " { $link render-set } " to instruct " { $link render } " to assemble primitives from the active " { $link vertex-array } " by using multiple arrays of indexes in CPU or GPU memory."
+{ $list
+{ "The " { $snippet "buffer" } " slot contains either a " { $link buffer } " object to read indexes from, or " { $link f } " to read from CPU memory." }
+{ "The " { $snippet "ptrs" } " slot contains either a " { $link void*-array } " of pointers to the starts of index data, or a pointer-sized " { $link ulong-array } " of offsets into " { $snippet "buffer" } "." }
+{ "The " { $snippet "counts" } " slot contains a " { $link uint-array } " containing the number of indexes to read from each pointer or offset in " { $snippet "ptrs" } "." }
+{ "The " { $snippet "index-type" } " slot contains an " { $link index-type } " value specifying whether the arrays consist of " { $link ubyte-indexes } ", " { $link ushort-indexes } ", or " { $link uint-indexes } "." }
+} } ;
+
+HELP: multi-index-range
+{ $class-description "Objects of this tuple class can be passed as the " { $snippet "indexes" } " slot of a non-instanced " { $link render-set } " to instruct " { $link render } " to assemble primitives from the active " { $link vertex-array } " by using multiple consecutive slices of its elements."
+{ $list
+{ "The " { $snippet "starts" } " slot contains a " { $link uint-array } " of indexes into the array from which to start generating primitives." }
+{ "The " { $snippet "counts" } " slot contains a " { $link uint-array } " of corresponding counts of indexes to read from each specified " { $snippet "start" } " index." }
+} } ;
+
+HELP: points-mode
+{ $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to generate a point for each indexed vertex array element." } ;
+
+HELP: primitive-mode
+{ $class-description "The " { $snippet "primitive-mode" } " slot of a " { $link render-set } " tells " { $link render } " what kind of primitives to generate and how to assemble them from the selected elements of the active " { $link vertex-array } "." }
+{ $list
+{ { $link points-mode } " causes each element to generate a point." }
+{ { $link lines-mode } " causes each pair of elements to generate a disconnected line." }
+{ { $link line-strip-mode } " causes each consecutive pair of elements to generate a connected strip of lines." }
+{ { $link line-loop-mode } " causes each consecutive pair of elements to generate a connected loop of lines, with an extra line connecting the last and first elements." }
+{ { $link triangles-mode } " causes every 3 elements to generate an independent triangle." }
+{ { $link triangle-strip-mode } " causes every consecutive group of 3 elements to generate a connected strip of triangles." }
+{ { $link triangle-fan-mode } " causes a triangle to be generated from the first element and every subsequent consecutive pair of elements in a fan pattern." } } ;
+
+{ primitive-mode points-mode lines-mode line-strip-mode line-loop-mode triangles-mode triangle-strip-mode triangle-fan-mode } related-words
+
+HELP: render
+{ $values
+ { "render-set" render-set }
+}
+{ $description "Submits a rendering job to the GPU. The values in the " { $link render-set } " tuple describe the job." } ;
+
+HELP: render-set
+{ $class-description "A " { $snippet "render-set" } " tuple describes a GPU rendering job."
+{ $list
+{ "The " { $link primitive-mode } " slot determines what kind of primitives should be rendered, and how they should be assembled." }
+{ "The " { $link vertex-array } " slot supplies the shader program and vertex data to be rendered." }
+{ "The " { $snippet "uniforms" } " slot contains a " { $link uniform-tuple } " with values for the shader program's uniform parameters." }
+{ "The " { $snippet "indexes" } " slot contains one of the " { $link vertex-indexes } " types and selects elements from the vertex array to be rendered." }
+{ "The " { $snippet "instances" } " slot, if not " { $link f } ", instructs the GPU to render several instances of the same set of vertexes. Instancing requires OpenGL 3.1 or one of the " { $snippet "GL_EXT_draw_instanced" } " or " { $snippet "GL_ARB_draw_instanced" } " extensions." }
+{ "The " { $snippet "framebuffer" } " slot determines the target for the rendering output. Either the " { $link system-framebuffer } " or a user-created " { $link framebuffer } " object can be specified. User-created framebuffers require OpenGL 3.0 or one of the " { $snippet "GL_EXT_framebuffer_object" } " or " { $snippet "GL_ARB_framebuffer_object" } " extensions." }
+{ "The " { $snippet "output-attachments" } " slot specifies which of the framebuffer's " { $link color-attachment-ref } "s to write the fragment shader's color output to. If the shader uses " { $snippet "gl_FragColor" } " or " { $snippet "gl_FragData[n]" } " to write its output, then " { $snippet "output-attachments" } " should be an array of " { $link color-attachment-ref } "s, and the output to color attachment binding is determined positionally. If the shader uses named output values, then " { $snippet "output-attachments" } " should be a list of string/" { $link color-attachment-ref } " pairs, mapping output names to color attachments. Named output values are available in GLSL 1.30 or later, and GLSL 1.20 and earlier using the " { $snippet "GL_EXT_gpu_shader4" } " extension." }
+} } ;
+
+{ render render-set } related-words
+
+HELP: texture-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " is a texture. The dimension of the corresponding " { $link uniform } " slot must be " { $snippet "1" } "." } ;
+
+HELP: triangle-fan-mode
+{ $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to generate a fan of triangles using the first indexed vertex array element and every subsequent consecutive pair of elements." } ;
+
+HELP: triangle-strip-mode
+{ $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to generate a strip of triangles using every consecutive group of 3 indexed vertex array elements." } ;
+
+HELP: triangles-mode
+{ $class-description "This " { $link primitive-mode } " value instructs " { $link render } " to generate a triangle for each group of 3 indexed vertex array elements." } ;
+
+HELP: ubyte-indexes
+{ $class-description "This " { $link index-type } " indicates that an " { $link index-elements } " or " { $link multi-index-elements } " buffer consists of unsigned byte indexes." } ;
+
+HELP: uint-indexes
+{ $class-description "This " { $link index-type } " indicates that an " { $link index-elements } " or " { $link multi-index-elements } " buffer consists of four-byte unsigned int indexes." } ;
+
+HELP: uint-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " is a scalar or vector of unsigned integers." } ;
+
+HELP: uniform
+{ $class-description "Values of this tuple type are passed to " { $link define-uniform-tuple } " to define a new " { $link uniform-tuple } " type." } ;
+
+HELP: uniform-tuple
+{ $class-description "The base class for tuple types defined with " { $link POSTPONE: UNIFORM-TUPLE: } ". A uniform tuple is used as part of a " { $link render-set } " to supply values for a shader program's uniform parameters. See the " { $link POSTPONE: UNIFORM-TUPLE: } " documentation for details on how uniform tuples are defined and used." } ;
+
+HELP: uniform-type
+{ $class-description { $snippet "uniform-type" } " values are used as part of a " { $link POSTPONE: UNIFORM-TUPLE: } " definition to define the types of uniform slots." } ;
+
+{ uniform-type bool-uniform int-uniform float-uniform texture-uniform uint-uniform } related-words
+
+HELP: ushort-indexes
+{ $class-description "This " { $link index-type } " indicates that an " { $link index-elements } " or " { $link multi-index-elements } " buffer consists of two-byte unsigned short indexes." } ;
+
+{ index-type ubyte-indexes ushort-indexes uint-indexes } related-words
+
+HELP: vertex-array
+{ $class-description "A " { $snippet "vertex-array" } " object associates a shader " { $link program-instance } " with vertex attribute data from one or more " { $link buffer } "s. The format of the binary data inside these buffers is described using " { $link vertex-format } "s. " { $snippet "vertex-array" } "s are constructed using the " { $link <vertex-array> } " or " { $link buffer>vertex-array } " words." } ;
+
+HELP: vertex-array-buffer
+{ $values
+ { "vertex-array" vertex-array }
+ { "vertex-buffer" buffer }
+}
+{ $description "Returns the first " { $link buffer } " object comprised in " { $snippet "vertex-array" } "." } ;
+
+HELP: vertex-attribute
+{ $class-description "This tuple type is passed to " { $link define-vertex-format } " to define a new " { $link vertex-format } " type." } ;
+
+HELP: vertex-format
+{ $class-description "This class encompasses all vertex formats defined by " { $link POSTPONE: VERTEX-FORMAT: } ". A vertex format defines the binary layout of vertex attribute data in a " { $link buffer } " for use as part of a " { $link vertex-array } ". See the " { $link POSTPONE: VERTEX-FORMAT: } " documentation for details on how vertex formats are defined." } ;
+
+HELP: vertex-format-size
+{ $values
+ { "format" vertex-format }
+ { "size" integer }
+}
+{ $description "Returns the size in bytes of a set of vertex attributes in " { $snippet "format" } "." } ;
+
+HELP: vertex-indexes
+{ $class-description "This class is a union of the following tuple types, any of which can be used as the " { $snippet "indexes" } " slot of a " { $link render-set } " to select elements from a " { $link vertex-array } " for rendering."
+{ $list
+{ "An " { $link index-range } " value submits a sequential slice of a vertex array for rendering." }
+{ "An " { $link index-elements } " value submits vertex array elements in an order specified by an array of indexes." }
+{ "A " { $link multi-index-range } " value submits multiple sequential slices of a vertex array." }
+{ "A " { $link multi-index-elements } " value submits multiple separate lists of indexed vertex array elements." }
+} } ;
+
+ARTICLE: "gpu.render" "Rendering"
+"The " { $vocab-link "gpu.render" } " vocabulary contains words for organizing and submitting data to the GPU for rendering."
+{ $subsection render }
+{ $subsection render-set }
+"Render data inside GPU " { $link buffer } "s is organized into " { $link vertex-array } "s for consumption by shader code:"
+{ $subsection vertex-array }
+{ $subsection <vertex-array> }
+{ $subsection buffer>vertex-array }
+{ $subsection POSTPONE: VERTEX-FORMAT: }
+{ $link uniform-tuple } "s provide Factor types for containing and submitting shader uniform parameters:"
+{ $subsection POSTPONE: UNIFORM-TUPLE: }
+;
+
+ABOUT: "gpu.render"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien alien.c-types alien.structs arrays
+assocs classes.mixin classes.parser classes.singleton
+classes.tuple classes.tuple.private combinators destructors fry
+generic generic.parser gpu gpu.buffers gpu.framebuffers
+gpu.framebuffers.private gpu.shaders gpu.state 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
+vocabs.parser words ;
+IN: gpu.render
+
+UNION: ?string string POSTPONE: f ;
+UNION: uniform-dim integer sequence ;
+
+TUPLE: vertex-attribute
+ { name ?string read-only initial: f }
+ { component-type component-type read-only initial: float-components }
+ { dim integer read-only initial: 4 }
+ { normalize? boolean read-only initial: f } ;
+
+VARIANT: uniform-type
+ bool-uniform
+ uint-uniform
+ int-uniform
+ float-uniform
+ texture-uniform ;
+
+TUPLE: uniform
+ { name string read-only initial: "" }
+ { uniform-type uniform-type read-only initial: float-uniform }
+ { dim uniform-dim read-only initial: 4 } ;
+
+VARIANT: index-type
+ ubyte-indexes
+ ushort-indexes
+ uint-indexes ;
+
+TUPLE: index-range
+ { start integer read-only }
+ { count integer read-only } ;
+
+C: <index-range> index-range
+
+TUPLE: multi-index-range
+ { starts uint-array read-only }
+ { counts uint-array read-only } ;
+
+C: <multi-index-range> multi-index-range
+
+UNION: ?integer integer POSTPONE: f ;
+
+TUPLE: index-elements
+ { ptr gpu-data-ptr read-only }
+ { count integer read-only }
+ { index-type index-type read-only } ;
+
+C: <index-elements> index-elements
+
+UNION: ?buffer buffer POSTPONE: f ;
+
+TUPLE: multi-index-elements
+ { buffer ?buffer read-only }
+ { ptrs read-only }
+ { counts uint-array read-only }
+ { index-type index-type read-only } ;
+
+C: <multi-index-elements> multi-index-elements
+
+UNION: vertex-indexes
+ index-range
+ multi-index-range
+ index-elements
+ multi-index-elements ;
+
+VARIANT: primitive-mode
+ points-mode
+ lines-mode
+ line-strip-mode
+ line-loop-mode
+ triangles-mode
+ triangle-strip-mode
+ triangle-fan-mode ;
+
+MIXIN: vertex-format
+
+TUPLE: uniform-tuple ;
+
+GENERIC: vertex-format-size ( format -- size )
+
+ERROR: invalid-uniform-type uniform ;
+
+<PRIVATE
+
+: gl-vertex-type ( component-type -- gl-type )
+ {
+ { ubyte-components [ GL_UNSIGNED_BYTE ] }
+ { ushort-components [ GL_UNSIGNED_SHORT ] }
+ { uint-components [ GL_UNSIGNED_INT ] }
+ { half-components [ GL_HALF_FLOAT ] }
+ { float-components [ GL_FLOAT ] }
+ { byte-integer-components [ GL_BYTE ] }
+ { short-integer-components [ GL_SHORT ] }
+ { int-integer-components [ GL_INT ] }
+ { ubyte-integer-components [ GL_UNSIGNED_BYTE ] }
+ { ushort-integer-components [ GL_UNSIGNED_SHORT ] }
+ { uint-integer-components [ GL_UNSIGNED_INT ] }
+ } case ;
+
+: vertex-type-size ( component-type -- size )
+ {
+ { ubyte-components [ 1 ] }
+ { ushort-components [ 2 ] }
+ { uint-components [ 4 ] }
+ { half-components [ 2 ] }
+ { float-components [ 4 ] }
+ { byte-integer-components [ 1 ] }
+ { short-integer-components [ 2 ] }
+ { int-integer-components [ 4 ] }
+ { ubyte-integer-components [ 1 ] }
+ { ushort-integer-components [ 2 ] }
+ { uint-integer-components [ 4 ] }
+ } case ;
+
+: vertex-attribute-size ( vertex-attribute -- size )
+ [ component-type>> vertex-type-size ] [ dim>> ] bi * ;
+
+: vertex-attributes-size ( vertex-attributes -- size )
+ [ vertex-attribute-size ] [ + ] map-reduce ;
+
+: gl-index-type ( index-type -- gl-index-type )
+ {
+ { ubyte-indexes [ GL_UNSIGNED_BYTE ] }
+ { ushort-indexes [ GL_UNSIGNED_SHORT ] }
+ { uint-indexes [ GL_UNSIGNED_INT ] }
+ } case ;
+
+: gl-primitive-mode ( primitive-mode -- gl-primitive-mode )
+ {
+ { points-mode [ GL_POINTS ] }
+ { lines-mode [ GL_LINES ] }
+ { line-strip-mode [ GL_LINE_STRIP ] }
+ { line-loop-mode [ GL_LINE_LOOP ] }
+ { triangles-mode [ GL_TRIANGLES ] }
+ { triangle-strip-mode [ GL_TRIANGLE_STRIP ] }
+ { triangle-fan-mode [ GL_TRIANGLE_FAN ] }
+ } case ;
+
+GENERIC: render-vertex-indexes ( primitive-mode vertex-indexes -- )
+
+GENERIC# render-vertex-indexes-instanced 1 ( primitive-mode vertex-indexes instances -- )
+
+M: index-range render-vertex-indexes
+ [ gl-primitive-mode ] [ [ start>> ] [ count>> ] bi ] bi* glDrawArrays ;
+
+M: index-range render-vertex-indexes-instanced
+ [ gl-primitive-mode ] [ [ start>> ] [ count>> ] bi ] [ ] tri*
+ glDrawArraysInstanced ;
+
+M: multi-index-range render-vertex-indexes
+ [ gl-primitive-mode ] [ [ starts>> ] [ counts>> dup length ] bi ] bi*
+ glMultiDrawArrays ;
+
+M: index-elements render-vertex-indexes
+ [ gl-primitive-mode ]
+ [ [ count>> ] [ index-type>> gl-index-type ] [ ptr>> ] tri ] bi*
+ index-buffer [ glDrawElements ] with-gpu-data-ptr ;
+
+M: index-elements render-vertex-indexes-instanced
+ [ gl-primitive-mode ]
+ [ [ count>> ] [ index-type>> gl-index-type ] [ ptr>> ] tri ]
+ [ ] tri*
+ swap index-buffer [ swap glDrawElementsInstanced ] with-gpu-data-ptr ;
+
+M: multi-index-elements render-vertex-indexes
+ [ gl-primitive-mode ]
+ [ { [ counts>> ] [ index-type>> gl-index-type ] [ ptrs>> dup length ] [ buffer>> ] } cleave ]
+ bi*
+ GL_ELEMENT_ARRAY_BUFFER swap [ handle>> ] [ 0 ] if* glBindBuffer glMultiDrawElements ;
+
+: (bind-texture-unit) ( texture-unit texture -- )
+ [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
+
+:: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
+ vertex-attribute name>> :> name
+ vertex-attribute component-type>> :> type
+ type gl-vertex-type :> gl-type
+ vertex-attribute dim>> :> dim
+ vertex-attribute normalize?>> >c-bool :> normalize?
+ vertex-attribute vertex-attribute-size :> size
+
+ stride offset size +
+ {
+ { [ name not ] [ [ 2drop ] ] }
+ {
+ [ type unnormalized-integer-components? ]
+ [
+ {
+ name attribute-index [ glEnableVertexAttribArray ] keep
+ dim gl-type stride offset
+ } >quotation :> dip-block
+
+ { dip-block dip <displaced-alien> glVertexAttribIPointer } >quotation
+ ]
+ }
+ [
+ {
+ name attribute-index [ glEnableVertexAttribArray ] keep
+ dim gl-type normalize? stride offset
+ } >quotation :> dip-block
+
+ { dip-block dip <displaced-alien> glVertexAttribPointer } >quotation
+ ]
+ } cond ;
+
+:: [bind-vertex-format] ( vertex-attributes -- quot )
+ vertex-attributes vertex-attributes-size :> stride
+ stride 0 vertex-attributes [ [bind-vertex-attribute] ] { } map-as 2nip :> attributes-cleave
+ { attributes-cleave 2cleave } >quotation :> with-block
+
+ { drop vertex-buffer with-block with-buffer-ptr } >quotation ;
+
+GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- )
+
+: define-vertex-format-methods ( class vertex-attributes -- )
+ [
+ [ \ bind-vertex-format create-method-in ] dip
+ [bind-vertex-format] define
+ ] [
+ [ \ vertex-format-size create-method-in ] dip
+ [ \ drop ] dip vertex-attributes-size [ ] 2sequence define
+ ] 2bi ;
+
+GENERIC: bind-uniform-textures ( program-instance uniform-tuple -- )
+GENERIC: bind-uniforms ( program-instance uniform-tuple -- )
+
+M: uniform-tuple bind-uniform-textures
+ 2drop ;
+M: uniform-tuple bind-uniforms
+ 2drop ;
+
+: uniform-slot-type ( uniform -- type )
+ dup dim>> 1 = [
+ uniform-type>> {
+ { bool-uniform [ boolean ] }
+ { uint-uniform [ integer ] }
+ { int-uniform [ integer ] }
+ { float-uniform [ float ] }
+ { texture-uniform [ texture ] }
+ } case
+ ] [ drop sequence ] if ;
+
+: uniform>slot ( uniform -- slot )
+ [ name>> ] [ uniform-slot-type ] bi 2array ;
+
+:: [bind-uniform-texture] ( uniform index -- quot )
+ uniform name>> reader-word :> value>>-word
+ { index swap value>>-word (bind-texture-unit) } >quotation ;
+
+:: [bind-uniform-textures] ( superclass uniforms -- quot )
+ superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
+ superclass \ bind-uniform-textures method :> next-method
+ uniforms
+ [ uniform-type>> texture-uniform = ] filter
+ [ first-texture-unit + [bind-uniform-texture] ] map-index
+ :> texture-uniforms-cleave
+
+ {
+ 2dup next-method
+ nip texture-uniforms-cleave cleave
+ } >quotation ;
+
+:: [bind-uniform] ( texture-unit uniform -- texture-unit' quot )
+ uniform name>> :> name
+ { name uniform-index } >quotation :> index-quot
+ uniform name>> reader-word 1quotation :> value>>-quot
+ { index-quot value>>-quot bi* } >quotation :> pre-quot
+
+ uniform [ uniform-type>> ] [ dim>> ] bi 2array H{
+ { { bool-uniform 1 } [ >c-bool glUniform1i ] }
+ { { int-uniform 1 } [ glUniform1i ] }
+ { { uint-uniform 1 } [ glUniform1ui ] }
+ { { float-uniform 1 } [ glUniform1f ] }
+
+ { { bool-uniform 2 } [ [ >c-bool ] map first2 glUniform2i ] }
+ { { int-uniform 2 } [ first2 glUniform2i ] }
+ { { uint-uniform 2 } [ first2 glUniform2ui ] }
+ { { float-uniform 2 } [ first2 glUniform2f ] }
+
+ { { bool-uniform 3 } [ [ >c-bool ] map first3 glUniform3i ] }
+ { { int-uniform 3 } [ first3 glUniform3i ] }
+ { { uint-uniform 3 } [ first3 glUniform3ui ] }
+ { { float-uniform 3 } [ first3 glUniform3f ] }
+
+ { { bool-uniform 4 } [ [ >c-bool ] map first4 glUniform4i ] }
+ { { int-uniform 4 } [ first4 glUniform4i ] }
+ { { uint-uniform 4 } [ first4 glUniform4ui ] }
+ { { float-uniform 4 } [ first4 glUniform4f ] }
+
+ { { float-uniform { 2 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2fv ] }
+ { { float-uniform { 3 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x3fv ] }
+ { { float-uniform { 4 2 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix2x4fv ] }
+
+ { { float-uniform { 2 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3x2fv ] }
+ { { float-uniform { 3 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3fv ] }
+ { { float-uniform { 4 3 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix3x4fv ] }
+
+ { { float-uniform { 2 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4x2fv ] }
+ { { float-uniform { 3 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4x3fv ] }
+ { { float-uniform { 4 4 } } [ [ 1 1 ] dip concat >float-array glUniformMatrix4fv ] }
+
+ { { texture-uniform 1 } { drop texture-unit glUniform1i } }
+ } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
+
+ uniform uniform-type>> texture-uniform =
+ [ texture-unit 1 + ] [ texture-unit ] if
+ pre-quot value-quot append ;
+
+:: [bind-uniforms] ( superclass uniforms -- quot )
+ superclass "uniform-tuple-texture-units" word-prop 0 or :> first-texture-unit
+ superclass \ bind-uniforms method :> next-method
+ first-texture-unit uniforms [ [bind-uniform] ] map nip :> uniforms-cleave
+
+ {
+ 2dup next-method
+ uniforms-cleave 2cleave
+ } >quotation ;
+
+: define-uniform-tuple-methods ( class superclass uniforms -- )
+ [
+ [ \ bind-uniform-textures create-method-in ] 2dip
+ [bind-uniform-textures] define
+ ] [
+ [ \ bind-uniforms create-method-in ] 2dip
+ [bind-uniforms] define
+ ] 3bi ;
+
+: parse-uniform-tuple-definition ( -- class superclass uniforms )
+ CREATE-CLASS scan {
+ { ";" [ uniform-tuple f ] }
+ { "<" [ scan-word parse-definition [ first3 uniform boa ] map ] }
+ { "{" [
+ uniform-tuple
+ \ } parse-until parse-definition swap prefix
+ [ first3 uniform boa ] map
+ ] }
+ } case ;
+
+: component-type>c-type ( component-type -- c-type )
+ {
+ { ubyte-components [ "uchar" ] }
+ { ushort-components [ "ushort" ] }
+ { uint-components [ "uint" ] }
+ { half-components [ "half" ] }
+ { float-components [ "float" ] }
+ { byte-integer-components [ "char" ] }
+ { ubyte-integer-components [ "uchar" ] }
+ { short-integer-components [ "short" ] }
+ { ushort-integer-components [ "ushort" ] }
+ { int-integer-components [ "int" ] }
+ { uint-integer-components [ "uint" ] }
+ } case ;
+
+: c-array-dim ( dim -- string )
+ dup 1 = [ drop "" ] [ number>string "[" "]" surround ] if ;
+
+SYMBOL: padding-no
+padding-no [ 0 ] initialize
+
+: padding-name ( -- name )
+ "padding-"
+ padding-no get number>string append
+ "(" ")" surround
+ padding-no inc ;
+
+: vertex-attribute>c-type ( vertex-attribute -- {type,name} )
+ [
+ [ component-type>> component-type>c-type ]
+ [ dim>> c-array-dim ] bi append
+ ] [ name>> [ padding-name ] unless* ] bi 2array ;
+
+: (define-uniform-tuple) ( class superclass uniforms -- )
+ {
+ [ [ uniform>slot ] map define-tuple-class ]
+ [ define-uniform-tuple-methods ]
+ [
+ [ "uniform-tuple-texture-units" word-prop 0 or ]
+ [ [ uniform-type>> texture-uniform = ] filter length ] bi* +
+ "uniform-tuple-texture-units" set-word-prop
+ ]
+ [ nip "uniform-tuple-slots" set-word-prop ]
+ } 3cleave ;
+
+: true-subclasses ( class -- seq )
+ [ subclasses ] keep [ = not ] curry filter ;
+
+: redefine-uniform-tuple-subclass-methods ( class -- )
+ [ true-subclasses ] keep
+ [ over "uniform-tuple-slots" word-prop (define-uniform-tuple) ] curry each ;
+
+PRIVATE>
+
+: define-vertex-format ( class vertex-attributes -- )
+ [
+ [
+ [ define-singleton-class ]
+ [ vertex-format add-mixin-instance ]
+ [ ] tri
+ ] [ define-vertex-format-methods ] bi*
+ ]
+ [ "vertex-format-attributes" set-word-prop ] 2bi ;
+
+SYNTAX: VERTEX-FORMAT:
+ CREATE-CLASS parse-definition
+ [ first4 vertex-attribute boa ] map
+ define-vertex-format ;
+
+: define-vertex-struct ( struct-name vertex-format -- )
+ [ current-vocab ] dip
+ "vertex-format-attributes" word-prop [ vertex-attribute>c-type ] map
+ define-struct ;
+
+SYNTAX: VERTEX-STRUCT:
+ scan scan-word define-vertex-struct ;
+
+: define-uniform-tuple ( class superclass uniforms -- )
+ [ (define-uniform-tuple) ]
+ [ 2drop redefine-uniform-tuple-subclass-methods ] 3bi ;
+
+SYNTAX: UNIFORM-TUPLE:
+ parse-uniform-tuple-definition define-uniform-tuple ;
+
+TUPLE: vertex-array < gpu-object
+ { program-instance program-instance read-only }
+ { vertex-buffers sequence read-only } ;
+
+M: vertex-array dispose
+ [ [ delete-vertex-array ] when* f ] change-handle drop ;
+
+: <vertex-array> ( program-instance vertex-formats -- vertex-array )
+ gen-vertex-array
+ [ glBindVertexArray [ first2 bind-vertex-format ] with each ]
+ [ -rot [ first buffer>> ] map vertex-array boa ] 3bi
+ window-resource ;
+
+: buffer>vertex-array ( vertex-buffer program-instance format -- vertex-array )
+ [ swap ] dip
+ [ 0 <buffer-ptr> ] dip 2array 1array <vertex-array> ; inline
+
+: vertex-array-buffer ( vertex-array -- vertex-buffer )
+ vertex-buffers>> first ;
+
+<PRIVATE
+
+: bind-vertex-array ( vertex-array -- )
+ handle>> glBindVertexArray ;
+
+: bind-unnamed-output-attachments ( framebuffer attachments -- )
+ [ gl-attachment ] with map
+ dup length 1 =
+ [ first glDrawBuffer ]
+ [ [ length ] [ >int-array ] bi glDrawBuffers ] if ;
+
+: bind-named-output-attachments ( program-instance framebuffer attachments -- )
+ rot '[ [ first _ swap output-index ] bi@ <=> ] sort [ second ] map
+ bind-unnamed-output-attachments ;
+
+: bind-output-attachments ( program-instance framebuffer attachments -- )
+ dup first sequence?
+ [ bind-named-output-attachments ] [ [ drop ] 2dip bind-unnamed-output-attachments ] if ;
+
+PRIVATE>
+
+TUPLE: render-set
+ { primitive-mode primitive-mode }
+ { vertex-array vertex-array }
+ { uniforms uniform-tuple }
+ { indexes vertex-indexes initial: T{ index-range } }
+ { instances ?integer initial: f }
+ { framebuffer any-framebuffer initial: system-framebuffer }
+ { output-attachments sequence initial: { default-attachment } } ;
+
+: render ( render-set -- )
+ {
+ [ vertex-array>> program-instance>> handle>> glUseProgram ]
+ [
+ [ vertex-array>> program-instance>> ] [ uniforms>> ] bi
+ [ bind-uniform-textures ] [ bind-uniforms ] 2bi
+ ]
+ [ GL_DRAW_FRAMEBUFFER swap framebuffer>> framebuffer-handle glBindFramebuffer ]
+ [
+ [ vertex-array>> program-instance>> ]
+ [ framebuffer>> ]
+ [ output-attachments>> ] tri
+ bind-output-attachments
+ ]
+ [ vertex-array>> bind-vertex-array ]
+ [
+ [ primitive-mode>> ] [ indexes>> ] [ instances>> ] tri
+ [ render-vertex-indexes-instanced ]
+ [ render-vertex-indexes ] if*
+ ]
+ } cleave ; inline
+
--- /dev/null
+Execution of GPU jobs
--- /dev/null
+USING: accessors debugger gpu.shaders io kernel prettyprint ;
+IN: gpu.shaders.prettyprint
+
+M: compile-shader-error error.
+ "The GLSL shader " write
+ [ shader>> name>> pprint-short " failed to compile." write nl ]
+ [ log>> write nl ] bi ;
+
+M: link-program-error error.
+ "The GLSL program " write
+ [ shader>> name>> pprint-short " failed to link." write nl ]
+ [ log>> write nl ] bi ;
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: help.markup help.syntax kernel math multiline quotations strings ;
+IN: gpu.shaders
+
+HELP: <program-instance>
+{ $values
+ { "program" program }
+ { "instance" program-instance }
+}
+{ $description "Compiles and links an instance of " { $snippet "program" } " for the current graphics context. If an instance already exists for " { $snippet "program" } " in the current context, it is reused." } ;
+
+HELP: <shader-instance>
+{ $values
+ { "shader" shader }
+ { "instance" shader-instance }
+}
+{ $description "Compiles an instance of " { $snippet "shader" } " for the current graphics context. If an instance already exists for " { $snippet "shader" } " in the current context, it is reused." } ;
+
+HELP: GLSL-PROGRAM:
+{ $syntax "GLSL-PROGRAM: program-name shader shader ... shader ;" }
+{ $description "Defines a new " { $link program } " named " { $snippet "program-name" } ". When the program is instantiated with " { $link <program-instance> } ", it will link together instances of all of the specified " { $link shader } "s to create the program instance." } ;
+
+HELP: GLSL-SHADER-FILE:
+{ $syntax "GLSL-SHADER-FILE: shader-name shader-kind \"filename\"" }
+{ $description "Defines a new " { $link shader } " of kind " { $link shader-kind } " named " { $snippet "shader-name" } ". The shader will read its source code from " { $snippet "filename" } " in the current Factor source file's directory." } ;
+
+HELP: GLSL-SHADER:
+{ $syntax <" GLSL-SHADER-FILE: shader-name shader-kind
+
+shader source
+
+; "> }
+{ $description "Defines a new " { $link shader } " of kind " { $link shader-kind } " named " { $snippet "shader-name" } ". The shader will read its source code from the current Factor source file between the " { $snippet "GLSL-SHADER:" } " line and the first subsequent line with a single semicolon on it." } ;
+
+{ POSTPONE: GLSL-PROGRAM: POSTPONE: GLSL-SHADER-FILE: POSTPONE: GLSL-SHADER: } related-words
+
+HELP: attribute-index
+{ $values
+ { "program-instance" program-instance } { "attribute-name" string }
+ { "index" integer }
+}
+{ $description "Returns the numeric index of the vertex attribute named " { $snippet "attribute-name" } " in " { $snippet "program-instance" } "." } ;
+
+HELP: compile-shader-error
+{ $class-description "An error compiling the source for a " { $link shader } "."
+{ $list
+{ "The " { $snippet "shader" } " slot indicates the shader that failed to compile." }
+{ "The " { $snippet "log" } " slot contains the error string from the GLSL compiler." }
+} } ;
+
+HELP: fragment-shader
+{ $class-description "This " { $link shader-kind } " indicates that a " { $link shader } " is a fragment shader." } ;
+
+HELP: link-program-error
+{ $class-description "An error linking the constituent shaders of a " { $link program } "."
+{ $list
+{ "The " { $snippet "program" } " slot indicates the program that failed to link." }
+{ "The " { $snippet "log" } " slot contains the error string from the GLSL linker." }
+} } ;
+
+{ compile-shader-error link-program-error } related-words
+
+HELP: output-index
+{ $values
+ { "program-instance" program-instance } { "output-name" string }
+ { "index" integer }
+}
+{ $description "Returns the numeric index of the fragment shader output named " { $snippet "output-name" } " in " { $snippet "program-instance" } "." }
+{ $notes "Named fragment shader outputs require OpenGL 3.0 or later and GLSL 1.30 or later, or OpenGL 2.0 or later and GLSL 1.20 or earlier with the " { $snippet "GL_EXT_gpu_shader4" } " extension." } ;
+
+HELP: program
+{ $class-description "A " { $snippet "program" } " provides a specification for linking a " { $link program-instance } " in a graphics context. Programs are defined with " { $link POSTPONE: GLSL-PROGRAM: } " and instantiated in a context with " { $link <program-instance> } "." } ;
+
+HELP: program-instance
+{ $class-description "A " { $snippet "program-instance" } " is a shader " { $link program } " that has been compiled and linked for a graphics context using " { $link <program-instance> } "." } ;
+
+HELP: refresh-program
+{ $values
+ { "program" program }
+}
+{ $description "Rereads the source code for every " { $link shader } " in " { $link program } " and attempts to refresh all the existing " { $link shader-instance } "s and " { $link program-instance } "s for those programs. If the new source code fails to compile or link, the existing instances are untouched; otherwise, they are updated on the fly to reference the newly compiled code." } ;
+
+HELP: shader
+{ $class-description "A " { $snippet "shader" } " provides a block of GLSL source code that can be compiled into a " { $link shader-instance } " in a graphics context. Shaders are defined with " { $link POSTPONE: GLSL-SHADER: } " or " { $link POSTPONE: GLSL-SHADER-FILE: } " and instantiated in a context with " { $link <shader-instance> } "." } ;
+
+HELP: shader-instance
+{ $class-description "A " { $snippet "shader-instance" } " is a " { $link shader } " that has been compiled for a graphics context using " { $link <shader-instance> } "." } ;
+
+HELP: shader-kind
+{ $class-description "A " { $snippet "shader-kind" } " value is passed as part of a " { $link POSTPONE: GLSL-SHADER: } " or " { $link POSTPONE: GLSL-SHADER-FILE: } " definition to indicate the kind of " { $link shader } " being defined."
+{ $list
+{ { $link vertex-shader } "s run during primitive assembly and map input vertex data to positions in screen space for rasterization." }
+{ { $link fragment-shader } "s run as part of rasterization and decide the final rendered output of a primitive as the outputs of the vertex shader are interpolated across its surface." }
+} } ;
+
+HELP: uniform-index
+{ $values
+ { "program-instance" program-instance } { "uniform-name" string }
+ { "index" integer }
+}
+{ $description "Returns the numeric index of the uniform parameter named " { $snippet "output-name" } " in " { $snippet "program-instance" } "." } ;
+
+HELP: vertex-shader
+{ $class-description "This " { $link shader-kind } " indicates that a " { $link shader } " is a vertex shader." } ;
+
+ARTICLE: "gpu.shaders" "Shader objects"
+"The " { $vocab-link "gpu.shaders" } " vocabulary supports defining, compiling, and linking " { $link shader } "s into " { $link program } "s that run on the GPU and control rendering."
+{ $subsection POSTPONE: GLSL-PROGRAM: }
+{ $subsection POSTPONE: GLSL-SHADER: }
+{ $subsection POSTPONE: GLSL-SHADER-FILE: }
+"A program must be instantiated for each graphics context it is used in:"
+{ $subsection <program-instance> }
+"Program instances can be updated on the fly, allowing for interactive development of shaders:"
+{ $subsection refresh-program } ;
+
+ABOUT: "gpu.shaders"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: multiline gpu.shaders gpu.shaders.private tools.test ;
+IN: gpu.shaders.tests
+
+[ <" ERROR: foo.factor:20: Bad command or filename
+INFO: foo.factor:30: The operation completed successfully
+NOT:A:LOG:LINE "> ]
+[ T{ shader { filename "foo.factor" } { line 19 } }
+<" ERROR: 0:1: Bad command or filename
+INFO: 0:11: The operation completed successfully
+NOT:A:LOG:LINE "> replace-log-line-numbers ] unit-test
+
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays assocs combinators
+combinators.short-circuit definitions destructors gpu
+io.encodings.ascii io.files io.pathnames kernel lexer
+locals math math.parser memoize multiline namespaces
+opengl.gl opengl.shaders parser sequences
+specialized-arrays.int splitting strings ui.gadgets.worlds
+variants hashtables vectors vocabs vocabs.loader words
+words.constant ;
+IN: gpu.shaders
+
+VARIANT: shader-kind
+ vertex-shader fragment-shader ;
+
+TUPLE: shader
+ { name word read-only initial: t }
+ { kind shader-kind read-only }
+ { filename read-only }
+ { line integer read-only }
+ { source string }
+ { instances hashtable read-only } ;
+
+TUPLE: program
+ { name word read-only initial: t }
+ { filename read-only }
+ { line integer read-only }
+ { shaders array read-only }
+ { instances hashtable read-only } ;
+
+TUPLE: shader-instance < gpu-object
+ { shader shader }
+ { world world } ;
+
+TUPLE: program-instance < gpu-object
+ { program program }
+ { world world } ;
+
+<PRIVATE
+
+: shader-filename ( shader/program -- filename )
+ dup filename>> [ nip ] [ name>> where first ] if* file-name ;
+
+: numbered-log-line? ( log-line-components -- ? )
+ {
+ [ length 4 >= ]
+ [ third string>number ]
+ } 1&& ;
+
+: replace-log-line-number ( object log-line -- log-line' )
+ ":" split dup numbered-log-line? [
+ {
+ [ nip first ]
+ [ drop shader-filename " " prepend ]
+ [ [ line>> ] [ third string>number ] bi* + number>string ]
+ [ nip 3 tail ]
+ } 2cleave [ 3array ] dip append
+ ] [ nip ] if ":" join ;
+
+: replace-log-line-numbers ( object log -- log' )
+ "\n" split [ empty? not ] filter
+ [ replace-log-line-number ] with map
+ "\n" join ;
+
+: gl-shader-kind ( shader-kind -- shader-kind )
+ {
+ { vertex-shader [ GL_VERTEX_SHADER ] }
+ { fragment-shader [ GL_FRAGMENT_SHADER ] }
+ } case ;
+
+PRIVATE>
+
+TUPLE: compile-shader-error shader log ;
+TUPLE: link-program-error program log ;
+
+: compile-shader-error ( shader instance -- * )
+ [ dup ] dip [ gl-shader-info-log ] [ delete-gl-shader ] bi replace-log-line-numbers
+ \ compile-shader-error boa throw ;
+
+: link-program-error ( program instance -- * )
+ [ dup ] dip [ gl-program-info-log ] [ delete-gl-program ] bi replace-log-line-numbers
+ \ link-program-error boa throw ;
+
+DEFER: <shader-instance>
+
+MEMO: uniform-index ( program-instance uniform-name -- index )
+ [ handle>> ] dip glGetUniformLocation ;
+MEMO: attribute-index ( program-instance attribute-name -- index )
+ [ handle>> ] dip glGetAttribLocation ;
+MEMO: output-index ( program-instance output-name -- index )
+ [ handle>> ] dip glGetFragDataLocation ;
+
+<PRIVATE
+
+: valid-handle? ( handle -- ? )
+ { [ ] [ zero? not ] } 1&& ;
+
+: compile-shader ( shader -- instance )
+ [ ] [ source>> ] [ kind>> gl-shader-kind ] tri <gl-shader>
+ dup gl-shader-ok?
+ [ swap world get \ shader-instance boa window-resource ]
+ [ compile-shader-error ] if ;
+
+: (link-program) ( program shader-instances -- program-instance )
+ [ handle>> ] map <gl-program>
+ dup gl-program-ok?
+ [ swap world get \ program-instance boa window-resource ]
+ [ link-program-error ] if ;
+
+: link-program ( program -- program-instance )
+ dup shaders>> [ <shader-instance> ] map (link-program) ;
+
+: in-word's-path ( word kind filename -- word kind filename' )
+ [ over ] dip [ where first parent-directory ] dip append-path ;
+
+: become-shader-instance ( shader-instance new-shader-instance -- )
+ handle>> [ swap delete-gl-shader ] curry change-handle drop ;
+
+: refresh-shader-source ( shader -- )
+ dup filename>>
+ [ ascii file-contents >>source drop ]
+ [ drop ] if* ;
+
+: become-program-instance ( program-instance new-program-instance -- )
+ handle>> [ swap delete-gl-program-only ] curry change-handle drop ;
+
+: reset-memos ( -- )
+ \ uniform-index reset-memoized
+ \ attribute-index reset-memoized
+ \ output-index reset-memoized ;
+
+: ?delete-at ( key assoc value -- )
+ 2over at = [ delete-at ] [ 2drop ] if ;
+
+: find-shader-instance ( shader -- instance )
+ world get over instances>> at*
+ [ nip ] [ drop compile-shader ] if ;
+
+: find-program-instance ( program -- instance )
+ world get over instances>> at*
+ [ nip ] [ drop link-program ] if ;
+
+PRIVATE>
+
+:: refresh-program ( program -- )
+ program shaders>> [ refresh-shader-source ] each
+ program instances>> [| world old-instance |
+ old-instance valid-handle? [
+ world [
+ [
+ program shaders>> [ compile-shader |dispose ] map :> new-shader-instances
+ program new-shader-instances (link-program) |dispose :> new-program-instance
+
+ old-instance new-program-instance become-program-instance
+ new-shader-instances [| new-shader-instance |
+ world new-shader-instance shader>> instances>> at
+ new-shader-instance become-shader-instance
+ ] each
+ ] with-destructors
+ ] with-gl-context
+ ] when
+ ] assoc-each
+ reset-memos ;
+
+: <shader-instance> ( shader -- instance )
+ [ find-shader-instance dup world get ] keep instances>> set-at ;
+
+: <program-instance> ( program -- instance )
+ [ find-program-instance dup world get ] keep instances>> set-at ;
+
+SYNTAX: GLSL-SHADER:
+ CREATE-WORD dup
+ scan-word
+ f
+ lexer get line>>
+ parse-here
+ H{ } clone
+ shader boa
+ define-constant ;
+
+SYNTAX: GLSL-SHADER-FILE:
+ CREATE-WORD dup
+ scan-word execute( -- kind )
+ scan-object in-word's-path
+ 0
+ over ascii file-contents
+ H{ } clone
+ shader boa
+ define-constant ;
+
+SYNTAX: GLSL-PROGRAM:
+ CREATE-WORD dup
+ f
+ lexer get line>>
+ \ ; parse-until >array [ def>> first ] map
+ H{ } clone
+ program boa
+ define-constant ;
+
+M: shader-instance dispose
+ [ dup valid-handle? [ delete-gl-shader ] [ drop ] if f ] change-handle
+ [ world>> ] [ shader>> instances>> ] [ ] tri ?delete-at ;
+
+M: program-instance dispose
+ [ dup valid-handle? [ delete-gl-program-only ] [ drop ] if f ] change-handle
+ [ world>> ] [ program>> instances>> ] [ ] tri ?delete-at
+ reset-memos ;
+
+"prettyprint" vocab [ "gpu.shaders.prettyprint" require ] when
--- /dev/null
+GPU programs that control vertex transformation and shading
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: help.markup help.syntax kernel math math.rectangles multiline sequences ;
+IN: gpu.state
+
+HELP: <blend-mode>
+{ $values
+ { "equation" blend-equation } { "source-function" blend-function } { "dest-function" blend-function }
+ { "blend-mode" blend-mode }
+}
+{ $description "Constructs a " { $link blend-mode } " tuple." } ;
+
+{ blend-mode <blend-mode> } related-words
+
+HELP: <blend-state>
+{ $values
+ { "constant-color" sequence } { "rgb-mode" { $maybe blend-mode } } { "alpha-mode" { $maybe blend-mode } }
+ { "blend-state" blend-state }
+}
+{ $description "Constructs a " { $link blend-state } " tuple." } ;
+
+{ blend-state <blend-state> get-blend-state } related-words
+
+HELP: <depth-range-state>
+{ $values
+ { "near" float } { "far" float }
+ { "depth-range-state" depth-range-state }
+}
+{ $description "Constructs a " { $link depth-range-state } " tuple." } ;
+
+{ depth-range-state <depth-range-state> get-depth-range-state } related-words
+
+HELP: <depth-state>
+{ $values
+ { "comparison" comparison }
+ { "depth-state" depth-state }
+}
+{ $description "Constructs a " { $link depth-state } " tuple." } ;
+
+{ depth-state <depth-state> get-depth-state } related-words
+
+HELP: <line-state>
+{ $values
+ { "width" float } { "antialias?" boolean }
+ { "line-state" line-state }
+}
+{ $description "Constructs a " { $link line-state } " tuple." } ;
+
+{ line-state <line-state> get-line-state } related-words
+
+HELP: <mask-state>
+{ $values
+ { "color" sequence } { "depth" boolean } { "stencil-front" boolean } { "stencil-back" boolean }
+ { "mask-state" mask-state }
+}
+{ $description "Constructs a " { $link mask-state } " tuple." } ;
+
+{ mask-state <mask-state> get-mask-state } related-words
+
+HELP: <multisample-state>
+{ $values
+ { "multisample?" boolean } { "sample-alpha-to-coverage?" boolean } { "sample-alpha-to-one?" boolean } { "sample-coverage" { $maybe float } } { "invert-sample-coverage?" boolean }
+ { "multisample-state" multisample-state }
+}
+{ $description "Constructs a " { $link multisample-state } " tuple." } ;
+
+{ multisample-state <multisample-state> get-multisample-state } related-words
+
+HELP: <point-state>
+{ $values
+ { "size" { $maybe float } } { "sprite-origin" point-sprite-origin } { "fade-threshold" float }
+ { "point-state" point-state }
+}
+{ $description "Constructs a " { $link point-state } " tuple." } ;
+
+{ point-state <point-state> get-point-state } related-words
+
+HELP: <scissor-state>
+{ $values
+ { "rect" { $maybe rect } }
+ { "scissor-state" scissor-state }
+}
+{ $description "Constructs a " { $link scissor-state } " tuple." } ;
+
+{ scissor-state <scissor-state> get-scissor-state } related-words
+
+HELP: <stencil-mode>
+{ $values
+ { "value" integer } { "mask" integer } { "comparison" comparison } { "stencil-fail-op" stencil-op } { "depth-fail-op" stencil-op } { "depth-pass-op" stencil-op }
+ { "stencil-mode" stencil-mode }
+}
+{ $description "Constructs a " { $link stencil-mode } " tuple." } ;
+
+{ stencil-mode <stencil-mode> } related-words
+
+HELP: <stencil-state>
+{ $values
+ { "front-mode" { $maybe stencil-mode } } { "back-mode" { $maybe stencil-mode } }
+ { "stencil-state" stencil-state }
+}
+{ $description "Constructs a " { $link stencil-state } " tuple." } ;
+
+{ stencil-state <stencil-state> get-stencil-state } related-words
+
+HELP: <triangle-cull-state>
+{ $values
+ { "front-face" triangle-face } { "cull" { $maybe triangle-cull } }
+ { "triangle-cull-state" triangle-cull-state }
+}
+{ $description "Constructs a " { $link triangle-cull-state } " tuple." } ;
+
+{ triangle-cull-state <triangle-cull-state> get-triangle-cull-state } related-words
+
+HELP: <triangle-state>
+{ $values
+ { "front-mode" triangle-mode } { "back-mode" triangle-mode } { "antialias?" boolean }
+ { "triangle-state" triangle-state }
+}
+{ $description "Constructs a " { $link triangle-state } " tuple." } ;
+
+{ triangle-state <triangle-state> get-triangle-state } related-words
+
+HELP: <viewport-state>
+{ $values
+ { "rect" rect }
+ { "viewport-state" viewport-state }
+}
+{ $description "Constructs a " { $link viewport-state } " tuple." } ;
+
+{ viewport-state <viewport-state> get-viewport-state } related-words
+
+HELP: blend-equation
+{ $class-description "The " { $snippet "blend-equation" } " of a " { $link blend-mode } " determines how the source and destination color values are combined after they have been multiplied by the result of their respective " { $link blend-function } "s."
+{ $list
+{ { $link eq-add } " indicates that the source and destination results are added." }
+{ { $link eq-subtract } " indicates that the destination result is subtracted from the source." }
+{ { $link eq-reverse-subtract } " indicates that the source result is subtracted from the destination." }
+{ { $link eq-min } " indicates that the componentwise minimum of the source and destination results is taken." }
+{ { $link eq-max } " indicates that the componentwise maximum of the source and destination results is taken." }
+} } ;
+
+HELP: blend-function
+{ $class-description "The " { $snippet "blend-function" } "s of a " { $link blend-mode } " multiply the source and destination colors being blended by a function of their values before they are combined by the " { $link blend-equation } "."
+{ $list
+ { { $link func-zero } " returns a constant factor of zero." }
+ { { $link func-one } " returns a constant factor of one." }
+ { { $link func-source } " returns the corresponding source color component for every result component." }
+ { { $link func-one-minus-source } " returns one minus the corresponding source color component for every result component." }
+ { { $link func-dest } " returns the corresponding destination color component for every result component." }
+ { { $link func-one-minus-dest } " returns one minus the corresponding destination color component for every result component." }
+ { { $link func-constant } " returns the corresponding component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
+ { { $link func-one-minus-constant } " returns one minus the corresponding component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
+ { { $link func-source-alpha } " returns the source alpha component for every result component." }
+ { { $link func-one-minus-source-alpha } " returns one minus the source alpha component for every result component." }
+ { { $link func-dest-alpha } " returns the destination alpha component for every result component." }
+ { { $link func-one-minus-dest-alpha } " returns one minus the destination alpha component for every result component." }
+ { { $link func-constant-alpha } " returns the alpha component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
+ { { $link func-one-minus-constant-alpha } " returns one minus the alpha component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
+} } ;
+
+HELP: blend-mode
+{ $class-description "A " { $link blend-mode } " is specified as part of the " { $link blend-state } " to determine the blending equation used between the source (incoming fragment) and destination (existing framebuffer value) colors of blended pixels."
+{ $list
+{ "The " { $snippet "equation" } " slot determines how the source and destination colors are combined after the " { $snippet "source-function" } " and " { $snippet "dest-function" } " have been applied."
+ { $list
+ { { $link eq-add } " indicates that the source and destination results are added." }
+ { { $link eq-subtract } " indicates that the destination result is subtracted from the source." }
+ { { $link eq-reverse-subtract } " indicates that the source result is subtracted from the destination." }
+ { { $link eq-min } " indicates that the componentwise minimum of the source and destination results is taken." }
+ { { $link eq-max } " indicates that the componentwise maximum of the source and destination results is taken." }
+ }
+}
+{ "The " { $snippet "source-function" } " and " { $snippet "dest-function" } " slots each specify a function to apply to the source, destination, or constant color values to generate a blending factor that is multiplied respectively against the source or destination value before feeding the results to the " { $snippet "equation" } "."
+}
+ { $list
+ { { $link func-zero } " returns a constant factor of zero." }
+ { { $link func-one } " returns a constant factor of one." }
+ { { $link func-source } " returns the corresponding source color component for every result component." }
+ { { $link func-one-minus-source } " returns one minus the corresponding source color component for every result component." }
+ { { $link func-dest } " returns the corresponding destination color component for every result component." }
+ { { $link func-one-minus-dest } " returns one minus the corresponding destination color component for every result component." }
+ { { $link func-constant } " returns the corresponding component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
+ { { $link func-one-minus-constant } " returns one minus the corresponding component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
+ { { $link func-source-alpha } " returns the source alpha component for every result component." }
+ { { $link func-one-minus-source-alpha } " returns one minus the source alpha component for every result component." }
+ { { $link func-dest-alpha } " returns the destination alpha component for every result component." }
+ { { $link func-one-minus-dest-alpha } " returns one minus the destination alpha component for every result component." }
+ { { $link func-constant-alpha } " returns the alpha component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
+ { { $link func-one-minus-constant-alpha } " returns one minus the alpha component of the current " { $link blend-state } "'s " { $snippet "constant-color" } " for every result component." }
+}
+"A typical transparency effect will use the values:"
+{ $code <" T{ blend-mode
+ { equation eq-add }
+ { source-function func-source-alpha }
+ { dest-function func-one-minus-source-alpha }
+} "> }
+} } ;
+
+HELP: blend-state
+{ $class-description "The " { $snippet "blend-state" } " controls how alpha blending between the current framebuffer contents and newly drawn pixels."
+{ $list
+{ "The " { $snippet "constant-color" } " slot contains an optional four-" { $link float } " sequence that specifies a constant parameter to the " { $snippet "func-*constant*" } " " { $link blend-function } "s. If constant blend functions are not used, the slot can be " { $link f } "." }
+{ "The " { $snippet "rgb-mode" } " and " { $snippet "alpha-mode" } " slots both contain " { $link blend-mode } " values that determine the blending equation used between RGB and alpha channel values, respectively. If both slots are " { $link f } ", blending is disabled." }
+} } ;
+
+HELP: cmp-always
+{ $class-description "This " { $link comparison } " test always succeeds." } ;
+
+HELP: cmp-equal
+{ $class-description "This " { $link comparison } " test succeeds if the compared values are equal." } ;
+
+HELP: cmp-greater
+{ $class-description "This " { $link comparison } " test succeeds if the incoming value is greater than the buffer value." } ;
+
+HELP: cmp-greater-equal
+{ $class-description "This " { $link comparison } " test succeeds if the incoming value is greater than or equal to the buffer value." } ;
+
+HELP: cmp-less
+{ $class-description "This " { $link comparison } " test succeeds if the incoming value is less than the buffer value." } ;
+
+HELP: cmp-less-equal
+{ $class-description "This " { $link comparison } " test succeeds if the incoming value is less than or equal to the buffer value." } ;
+
+HELP: cmp-never
+{ $class-description "This " { $link comparison } " test always fails." } ;
+
+HELP: cmp-not-equal
+{ $class-description "This " { $link comparison } " test succeeds if the compared values are not equal." } ;
+
+HELP: comparison
+{ $class-description { $snippet "comparison" } " values are used in the " { $link stencil-state } " and " { $link depth-state } " and control how the fragment stencil and depth tests are performed. For the stencil test, a reference value (the " { $snippet "value" } " slot of the active " { $link stencil-mode } ") is compared to the stencil buffer value using the comparison operator. For the depth test, the incoming fragment depth is compared to the depth buffer value."
+{ $list
+{ { $link cmp-always } " always succeeds." }
+{ { $link cmp-never } " always fails." }
+{ { $link cmp-equal } " succeeds if the compared values are equal." }
+{ { $link cmp-not-equal } " succeeds if the compared values are not equal." }
+{ { $link cmp-less } " succeeds if the incoming value is less than the buffer value." }
+{ { $link cmp-less-equal } " succeeds if the incoming value is less than or equal to the buffer value." }
+{ { $link cmp-greater } " succeeds if the incoming value is greater than the buffer value." }
+{ { $link cmp-greater-equal } " succeeds if the incoming value is greater than or equal to the buffer value." }
+} } ;
+
+HELP: cull-all
+{ $class-description "This " { $link triangle-cull } " value culls all triangles." } ;
+
+HELP: cull-back
+{ $class-description "This " { $link triangle-cull } " value culls back-facing triangles." } ;
+
+HELP: cull-front
+{ $class-description "This " { $link triangle-cull } " value culls front-facing triangles." } ;
+
+HELP: depth-range-state
+{ $class-description "The " { $snippet "depth-range-state" } " controls the range of depth values that are generated for fragments and used for depth testing and writing to the depth buffer."
+{ $list
+{ "The " { $snippet "near" } " slot contains a " { $link float } " value that will be assigned to fragments on the near plane. The default value is " { $snippet "0.0" } "." }
+{ "The " { $snippet "far" } " slot contains a " { $link float } " value that will be assigned to fragments on the far plane. The default value is " { $snippet "1.0" } "." }
+} } ;
+
+HELP: depth-state
+{ $class-description "The " { $snippet "depth-state" } " controls how incoming fragments' depth values are tested against the depth buffer. The " { $link comparison } " slot, if not " { $link f } ", determines the condition that must be true between the incoming fragment depth and depth buffer depth to pass a fragment. If the " { $snippet "comparison" } " is " { $link f } ", depth testing is disabled and all fragments pass. " { $link cmp-less } " is typically used for depth culling." } ;
+
+HELP: eq-add
+{ $var-description "This " { $link blend-equation } " adds the source and destination colors together." } ;
+
+HELP: eq-max
+{ $var-description "This " { $link blend-equation } " takes the componentwise maximum of the source and destination colors." } ;
+
+HELP: eq-min
+{ $var-description "This " { $link blend-equation } " takes the componentwise minimum of the source and destination colors." } ;
+
+HELP: eq-reverse-subtract
+{ $var-description "This " { $link blend-equation } " subtracts the source color from the destination color." } ;
+
+HELP: eq-subtract
+{ $var-description "This " { $link blend-equation } " subtracts the destination color from the source color." } ;
+
+HELP: face-ccw
+{ $class-description "This " { $link triangle-face } " value refers to the face with counterclockwise-wound vertices." } ;
+
+HELP: face-cw
+{ $class-description "This " { $link triangle-face } " value refers to the face with clockwise-wound vertices." } ;
+
+HELP: func-constant
+{ $class-description "This " { $link blend-function } " componentwise multiplies the input color by the current " { $link blend-state } "'s " { "constant-color" } " slot value." } ;
+
+HELP: func-constant-alpha
+{ $class-description "This " { $link blend-function } " multiplies the input color by the alpha component of the current " { $link blend-state } "'s " { "constant-color" } " slot value." } ;
+
+HELP: func-dest
+{ $class-description "This " { $link blend-function } " componentwise multiplies the input color by the destination color value." } ;
+
+HELP: func-dest-alpha
+{ $class-description "This " { $link blend-function } " componentwise multiplies the input color by the alpha component of the destination color value." } ;
+
+HELP: func-one
+{ $class-description "This " { $link blend-function } " multiplies the input color by one; that is, the input color is unchanged." } ;
+
+HELP: func-one-minus-constant
+{ $class-description "This " { $link blend-function } " componentwise multiplies the input color by one minus the current " { $link blend-state } "'s " { "constant-color" } " slot value." } ;
+
+HELP: func-one-minus-constant-alpha
+{ $class-description "This " { $link blend-function } " multiplies the input color by one minus the alpha component of the current " { $link blend-state } "'s " { "constant-color" } " slot value." } ;
+
+HELP: func-one-minus-dest
+{ $class-description "This " { $link blend-function } " componentwise multiplies the input color by one minus the destination color value." } ;
+
+HELP: func-one-minus-dest-alpha
+{ $class-description "This " { $link blend-function } " multiplies the input color by one minus the alpha component of the destination color value." } ;
+
+HELP: func-one-minus-source
+{ $class-description "This " { $link blend-function } " componentwise multiplies the input color by one minus the source color value." } ;
+
+HELP: func-one-minus-source-alpha
+{ $class-description "This " { $link blend-function } " multiplies the input color by one minus the alpha component source color value." } ;
+
+HELP: func-source
+{ $class-description "This " { $link blend-function } " componentwise multiplies the input color by the source color value." } ;
+
+HELP: func-source-alpha
+{ $class-description "This " { $link blend-function } " multiplies the input color by the alpha component of the source color value." } ;
+
+HELP: func-source-alpha-saturate
+{ $class-description "This " { $link blend-function } " multiplies the input color by the minimum of the alpha component of the source color value and one minus the alpha component of the destination color value. It is only valid as the " { $snippet "source-function" } " of a " { $link blend-mode } "." } ;
+
+HELP: func-zero
+{ $class-description "This " { $link blend-function } " multiplies the input color by zero." } ;
+
+HELP: get-blend-state
+{ $values
+
+ { "blend-state" blend-state }
+}
+{ $description "Retrieves the current GPU " { $link blend-state } "." } ;
+
+HELP: get-depth-range-state
+{ $values
+
+ { "depth-range-state" depth-range-state }
+}
+{ $description "Retrieves the current GPU " { $link depth-range-state } "." } ;
+
+HELP: get-depth-state
+{ $values
+
+ { "depth-state" depth-state }
+}
+{ $description "Retrieves the current GPU " { $link depth-state } "." } ;
+
+HELP: get-line-state
+{ $values
+
+ { "line-state" line-state }
+}
+{ $description "Retrieves the current GPU " { $link line-state } "." } ;
+
+HELP: get-mask-state
+{ $values
+
+ { "mask-state" mask-state }
+}
+{ $description "Retrieves the current GPU " { $link mask-state } "." } ;
+
+HELP: get-multisample-state
+{ $values
+
+ { "multisample-state" multisample-state }
+}
+{ $description "Retrieves the current GPU " { $link multisample-state } "." } ;
+
+HELP: get-point-state
+{ $values
+
+ { "point-state" point-state }
+}
+{ $description "Retrieves the current GPU " { $link point-state } "." } ;
+
+HELP: get-scissor-state
+{ $values
+
+ { "scissor-state" scissor-state }
+}
+{ $description "Retrieves the current GPU " { $link scissor-state } "." } ;
+
+HELP: get-stencil-state
+{ $values
+
+ { "stencil-state" stencil-state }
+}
+{ $description "Retrieves the current GPU " { $link stencil-state } "." } ;
+
+HELP: get-triangle-cull-state
+{ $values
+
+ { "triangle-cull-state" triangle-cull-state }
+}
+{ $description "Retrieves the current GPU " { $link triangle-cull-state } "." } ;
+
+HELP: get-triangle-state
+{ $values
+
+ { "triangle-state" triangle-state }
+}
+{ $description "Retrieves the current GPU " { $link triangle-state } "." } ;
+
+HELP: get-viewport-state
+{ $values
+
+ { "viewport-state" viewport-state }
+}
+{ $description "Retrieves the current GPU " { $link viewport-state } "." } ;
+
+HELP: gpu-state
+{ $class-description "This class is a union of all the GPU state tuple classes that can be passed to " { $link set-gpu-state } ":"
+{ $list
+{ { $link viewport-state } }
+{ { $link scissor-state } }
+{ { $link multisample-state } }
+{ { $link stencil-state } }
+{ { $link depth-range-state } }
+{ { $link depth-state } }
+{ { $link blend-state } }
+{ { $link mask-state } }
+{ { $link triangle-cull-state } }
+{ { $link triangle-state } }
+{ { $link point-state } }
+{ { $link line-state } }
+} } ;
+
+HELP: line-state
+{ $class-description "The " { $snippet "line-state" } " controls how lines are rendered."
+{ $list
+{ "The " { $snippet "width" } " slot is a " { $link float } " value specifying the line width in pixels." }
+{ "The " { $snippet "antialias?" } " slot is a " { $link boolean } " value specifying whether line edges should be smoothed." }
+}
+} ;
+
+HELP: mask-state
+{ $class-description "The " { $snippet "mask-state" } " controls what parts of the framebuffer are written to."
+{ $list
+{ "The " { $snippet "color" } " slot is a sequence of four " { $link boolean } " values specifying whether the red, green, blue, and alpha channels of the color buffer will be written to." }
+{ "The " { $snippet "depth" } " slot is a " { $link boolean } " value specifying whether the depth buffer will be written to." }
+{ "The " { $snippet "stencil-front" } " and " { $snippet "stencil-back" } " slots are " { $link integer } " values that indicate which bits of the stencil buffer will be written to for front- and back-facing triangles, respectively." }
+} } ;
+
+HELP: multisample-state
+{ $class-description "The " { $snippet "multisample-state" } " controls whether and how multisampling occurs."
+{ $list
+{ "The " { $snippet "multisample?" } " slot is a " { $link boolean } " value that determines whether multisampling is enabled." }
+{ "The " { $snippet "sample-alpha-to-coverage?" } " slot is a " { $link boolean } " value that determines whether sample coverage values are determined from their alpha components." }
+{ "The " { $snippet "sample-alpha-to-one?" } " slot is a " { $link boolean } " value that determines whether a sample's alpha value is replaced with one after its alpha-based coverage is calculated." }
+{ "The " { $snippet "sample-coverage" } " slot is an optional " { $link float } " value that is used to calculate another coverage value that is then combined with the alpha-based coverage. If " { $link f } ", the alpha-based coverage is untouched." }
+{ "The " { $snippet "invert-sample-coverage?" } " slot is a " { $link boolean } " value that, if true, indicates that the coverage value derived from " { $snippet "sample-coverage" } " should be inverted before being combined." }
+} } ;
+
+HELP: op-dec-sat
+{ $class-description "This " { $link stencil-op } " subtracts one from the stencil buffer value, leaving it unchanged if it is already zero." } ;
+
+HELP: op-dec-wrap
+{ $class-description "This " { $link stencil-op } " subtracts one from the stencil buffer value, wrapping the value to the maximum storable value if it was zero." } ;
+
+HELP: op-inc-sat
+{ $class-description "This " { $link stencil-op } " adds one to the stencil buffer value, leaving it unchanged if it is already the maximum storable value." } ;
+
+HELP: op-inc-wrap
+{ $class-description "This " { $link stencil-op } " adds one to the stencil buffer value, wrapping the value to zero if it was the maximum storable value." } ;
+
+HELP: op-invert
+{ $class-description "This " { $link stencil-op } " bitwise NOTs the stencil buffer value." } ;
+
+HELP: op-keep
+{ $class-description "This " { $link stencil-op } " leaves the stencil buffer value unchanged." } ;
+
+HELP: op-replace
+{ $class-description "This " { $link stencil-op } " sets the stencil buffer value to the reference " { $snippet "value" } "." } ;
+
+HELP: op-zero
+{ $class-description "This " { $link stencil-op } " sets the stencil buffer value to zero." } ;
+
+HELP: origin-lower-left
+{ "This " { $link point-sprite-origin } " value sets the point sprite coordinate origin to the lower left corner of the point and increases the Y coordinate upward." } ;
+
+HELP: origin-upper-left
+{ "This " { $link point-sprite-origin } " value sets the point sprite coordinate origin to the upper left corner of the point and increases the Y coordinate downward." } ;
+
+HELP: point-sprite-origin
+{ $class-description "The " { $snippet "point-sprite-origin" } " is set as part of the " { $link point-state } " and determines how point sprite coordinates are generated over the rendered area of a point."
+{ $list
+{ { $link origin-lower-left } " sets the coordinate origin to the lower left corner of the point and increases the Y coordinate upward." }
+{ { $link origin-upper-left } " sets the coordinate origin to the upper left corner of the point and increases the Y coordinate downward." }
+} } ;
+
+HELP: point-state
+{ $class-description "The " { $snippet "point-state" } " controls how points are drawn."
+{ $list
+{ "The " { $snippet "size" } " slot contains either a " { $link float } " value specifying a constant pixel radius for all points drawn, or " { $link f } ", in which case the vertex shader determines the size of each point independently." }
+{ "The " { $snippet "sprite-origin" } " slot contains either " { $link origin-lower-left } " or " { $link origin-upper-left } ", and determines whether the vertical point sprite coordinates fed to the fragment shader start at zero in the bottom corner and increase upward or start at zero in the upper corner and increase downward." }
+{ "If multisampling is enabled in the " { $link multisample-state } ", the " { $snippet "fade-threshold" } " slot specifies a pixel width at which the multisampling implementation may fade the alpha component of point fragments." }
+} } ;
+
+HELP: scissor-state
+{ $class-description "The " { $snippet "scissor-state" } " allows rendering output to be clipped to a rectangular region of the framebuffer. If the " { $snippet "rect" } " slot is set to a " { $link rect } " value, fragments outside that rectangle will be discarded. If it is " { $link f } ", fragments are allowed anywhere on the framebuffer." } ;
+
+HELP: set-gpu-state
+{ $values
+ { "states" "a " { $link sequence } " or " { $link gpu-state } }
+}
+{ $description "Changes the GPU state using the values passed in " { $snippet "states" } "." } ;
+
+HELP: set-gpu-state*
+{ $values
+ { "state" gpu-state }
+}
+{ $description "Changes the GPU state using a single " { $link gpu-state } " value." } ;
+
+HELP: stencil-mode
+{ $class-description "A " { $snippet "stencil-mode" } " is specified as part of the " { $link stencil-state } " to define the interaction between an incoming fragment and the stencil buffer."
+{ $list
+{ "The " { $snippet "value" } " slot contains an " { $link integer } " value that is used as the reference value for the " { $snippet "comparison" } " of the stencil test." }
+{ "The " { $snippet "mask" } " slot contains an " { $link integer } " mask value that indicates which bits are relevant to the stencil test." }
+{ "The " { $snippet "comparison" } " slot contains a " { $link comparison } " value that indicates the comparison taken between the masked reference value and stored stencil buffer value to determine whether the fragment is allowed to pass." }
+{ "The " { $snippet "stencil-fail-op" } ", " { $snippet "depth-fail-op" } ", and " { $snippet "depth-pass-op" } " slots all contain " { $link stencil-op } " values that determine how the value in the stencil buffer is affected when the stencil test fails, the stencil test succeeds but depth test fails, and both stencil and depth tests succeed, respectively."
+ { $list
+ { { $link op-keep } " leaves the stencil buffer value unchanged." }
+ { { $link op-zero } " sets the stencil buffer value to zero." }
+ { { $link op-replace } " sets the stencil buffer value to the reference " { $snippet "value" } "." }
+ { { $link op-invert } " bitwise NOTs the stencil buffer value." }
+ { { $link op-inc-sat } " adds one to the stencil buffer value, leaving it unchanged if it is already the maximum storable value." }
+ { { $link op-dec-sat } " subtracts one from the stencil buffer value, leaving it unchanged if it is already zero." }
+ { { $link op-inc-wrap } " adds one to the stencil buffer value, wrapping the value to zero if it was the maximum storable value." }
+ { { $link op-dec-wrap } " subtracts one from the stencil buffer value, wrapping the value to the maximum storable value if it was zero." }
+ }
+}
+} } ;
+
+HELP: stencil-op
+{ $class-description { $snippet "stencil-op" } "s are set as part of a " { $link stencil-mode } " and determine how the stencil buffer is modified by incoming fragments."
+{ $list
+{ { $link op-keep } " leaves the stencil buffer value unchanged." }
+{ { $link op-zero } " sets the stencil buffer value to zero." }
+{ { $link op-replace } " sets the stencil buffer value to the reference " { $snippet "value" } "." }
+{ { $link op-invert } " bitwise NOTs the stencil buffer value." }
+{ { $link op-inc-sat } " adds one to the stencil buffer value, leaving it unchanged if it is already the maximum storable value." }
+{ { $link op-dec-sat } " subtracts one from the stencil buffer value, leaving it unchanged if it is already zero." }
+{ { $link op-inc-wrap } " adds one to the stencil buffer value, wrapping the value to zero if it was the maximum storable value." }
+{ { $link op-dec-wrap } " subtracts one from the stencil buffer value, wrapping the value to the maximum storable value if it was zero." }
+} } ;
+
+HELP: stencil-state
+{ $class-description "The " { $snippet "stencil-state" } " controls how incoming fragments interact with the stencil buffer. The " { $snippet "front-mode" } " and " { $snippet "back-mode" } " slots are both " { $link stencil-mode } " tuples that define the stencil buffer interaction for front- and back-facing triangle fragments, respectively. If both slots are " { $link f } ", stencil testing is disabled." } ;
+
+HELP: triangle-cull
+{ $class-description "The " { $snippet "cull" } " slot of the " { $link triangle-cull-state } " determines which triangle faces are culled, if any."
+{ $list
+{ { $link cull-all } " culls all triangles." }
+{ { $link cull-front } " culls front-facing triangles." }
+{ { $link cull-back } " culls back-facing triangles." }
+} } ;
+
+HELP: triangle-cull-state
+{ $class-description "The " { $snippet "triangle-cull-state" } " controls what faces of triangles are rasterized."
+{ $list
+{ "The " { $snippet "front-face" } " slot determines which vertex winding order is considered the front face of a triangle: " { $link face-ccw } " or " { $link face-cw } "." }
+{ "The " { $snippet "cull" } " slot determines which triangle faces are discarded: " { $link cull-front } ", " { $link cull-back } ", " { $link cull-all } ", or " { $link f } " to disable triangle culling." }
+} } ;
+
+HELP: triangle-face
+{ $class-description "A " { $snippet "triangle-face" } " value names a vertex winding order for triangles."
+{ $list
+{ { $link face-ccw } " indicates counterclockwise winding." }
+{ { $link face-cw } " indicates clockwise winding." }
+} } ;
+
+HELP: triangle-fill
+{ $class-description "This " { $link triangle-mode } " fills the entire surface of triangles." } ;
+
+HELP: triangle-lines
+{ $class-description "This " { $link triangle-mode } " renders lines across the edges of triangles." } ;
+
+HELP: triangle-mode
+{ $class-description "The " { $snippet "triangle-mode" } " is set as part of the " { $link triangle-state } " to determine how triangles are rendered."
+{ $list
+{ { $link triangle-points } " renders the vertices of triangles as if they were points." }
+{ { $link triangle-lines } " renders lines across the edges of triangles." }
+{ { $link triangle-fill } ", the default, fills the entire surface of triangles." }
+} } ;
+
+HELP: triangle-points
+{ $class-description "This " { $link triangle-mode } " renders the vertices of triangles as if they were points." } ;
+
+HELP: triangle-state
+{ $class-description "The " { $snippet "triangle-state" } " controls how triangles are rasterized."
+{ $list
+{ "The " { $snippet "front-mode" } " and " { $snippet "back-mode" } " slots determine how a front- or back-facing triangle is rendered."
+ { $list
+ { { $link triangle-points } " renders the vertices of triangles as if they were points." }
+ { { $link triangle-lines } " renders lines across the edges of triangles." }
+ { { $link triangle-fill } ", the default, fills the entire surface of triangles." }
+ }
+}
+{ "The " { $snippet "antialias?" } " slot contains a " { $link boolean } " value that decides whether the edges of triangles should be smoothed." }
+} } ;
+
+HELP: viewport-state
+{ $class-description "The " { $snippet "viewport-state" } " controls the rectangular region of the framebuffer to which window-space coordinates are mapped. Window-space vertices are mapped from the rectangle <-1.0, -1.0>Â<1.0, 1.0> to the rectangular region specified by the " { $snippet "rect" } " slot." } ;
+
+ARTICLE: "gpu.state" "GPU state"
+"The " { $vocab-link "gpu.state" } " vocabulary provides words for querying and setting GPU state."
+{ $subsection set-gpu-state }
+"The following state tuples are available:"
+{ $subsection viewport-state }
+{ $subsection scissor-state }
+{ $subsection multisample-state }
+{ $subsection stencil-state }
+{ $subsection depth-range-state }
+{ $subsection depth-state }
+{ $subsection blend-state }
+{ $subsection mask-state }
+{ $subsection triangle-cull-state }
+{ $subsection triangle-state }
+{ $subsection point-state }
+{ $subsection line-state } ;
+
+ABOUT: "gpu.state"
--- /dev/null
+! (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 ;
+IN: gpu.state
+
+UNION: ?rect rect POSTPONE: f ;
+UNION: ?float float POSTPONE: f ;
+
+TUPLE: viewport-state
+ { rect rect read-only } ;
+C: <viewport-state> viewport-state
+
+TUPLE: scissor-state
+ { rect ?rect read-only } ;
+C: <scissor-state> scissor-state
+
+TUPLE: multisample-state
+ { multisample? boolean read-only }
+ { sample-alpha-to-coverage? boolean read-only }
+ { sample-alpha-to-one? boolean read-only }
+ { sample-coverage ?float read-only }
+ { invert-sample-coverage? boolean read-only } ;
+C: <multisample-state> multisample-state
+
+VARIANT: comparison
+ cmp-never cmp-always
+ cmp-less cmp-less-equal cmp-equal
+ cmp-greater-equal cmp-greater cmp-not-equal ;
+VARIANT: stencil-op
+ op-keep op-zero
+ op-replace op-invert
+ op-inc-sat op-dec-sat
+ op-inc-wrap op-dec-wrap ;
+
+UNION: ?comparison comparison POSTPONE: f ;
+
+TUPLE: stencil-mode
+ { value integer initial: 0 read-only }
+ { mask integer initial: HEX: FFFFFFFF read-only }
+ { comparison comparison initial: cmp-always read-only }
+ { stencil-fail-op stencil-op initial: op-keep read-only }
+ { depth-fail-op stencil-op initial: op-keep read-only }
+ { depth-pass-op stencil-op initial: op-keep read-only } ;
+C: <stencil-mode> stencil-mode
+
+UNION: ?stencil-mode stencil-mode POSTPONE: f ;
+
+TUPLE: stencil-state
+ { front-mode ?stencil-mode initial: f read-only }
+ { back-mode ?stencil-mode initial: f read-only } ;
+C: <stencil-state> stencil-state
+
+TUPLE: depth-range-state
+ { near float initial: 0.0 read-only }
+ { far float initial: 1.0 read-only } ;
+C: <depth-range-state> depth-range-state
+
+TUPLE: depth-state
+ { comparison ?comparison initial: f read-only } ;
+C: <depth-state> depth-state
+
+VARIANT: blend-equation
+ eq-add eq-subtract eq-reverse-subtract eq-min eq-max ;
+VARIANT: blend-function
+ func-zero func-one
+ func-source func-one-minus-source
+ func-dest func-one-minus-dest
+ func-constant func-one-minus-constant
+ func-source-alpha func-one-minus-source-alpha
+ func-dest-alpha func-one-minus-dest-alpha
+ func-constant-alpha func-one-minus-constant-alpha ;
+
+VARIANT: source-only-blend-function
+ func-source-alpha-saturate ;
+
+UNION: source-blend-function blend-function source-only-blend-function ;
+
+TUPLE: blend-mode
+ { equation blend-equation initial: eq-add read-only }
+ { source-function source-blend-function initial: func-source-alpha read-only }
+ { dest-function blend-function initial: func-one-minus-source-alpha read-only } ;
+C: <blend-mode> blend-mode
+
+UNION: ?blend-mode blend-mode POSTPONE: f ;
+
+TUPLE: blend-state
+ { constant-color sequence initial: f read-only }
+ { rgb-mode ?blend-mode read-only }
+ { alpha-mode ?blend-mode read-only } ;
+C: <blend-state> blend-state
+
+TUPLE: mask-state
+ { color sequence initial: { t t t t } read-only }
+ { depth boolean initial: t read-only }
+ { stencil-front integer initial: HEX: FFFFFFFF read-only }
+ { stencil-back integer initial: HEX: FFFFFFFF read-only } ;
+C: <mask-state> mask-state
+
+VARIANT: triangle-face
+ face-ccw face-cw ;
+VARIANT: triangle-cull
+ cull-front cull-back cull-all ;
+VARIANT: triangle-mode
+ triangle-points triangle-lines triangle-fill ;
+
+UNION: ?triangle-cull triangle-cull POSTPONE: f ;
+
+TUPLE: triangle-cull-state
+ { front-face triangle-face initial: face-ccw read-only }
+ { cull ?triangle-cull initial: f read-only } ;
+C: <triangle-cull-state> triangle-cull-state
+
+TUPLE: triangle-state
+ { front-mode triangle-mode initial: triangle-fill read-only }
+ { back-mode triangle-mode initial: triangle-fill read-only }
+ { antialias? boolean initial: f read-only } ;
+C: <triangle-state> triangle-state
+
+VARIANT: point-sprite-origin
+ origin-upper-left origin-lower-left ;
+
+TUPLE: point-state
+ { size ?float initial: 1.0 read-only }
+ { sprite-origin point-sprite-origin initial: origin-upper-left read-only }
+ { fade-threshold float initial: 1.0 read-only } ;
+C: <point-state> point-state
+
+TUPLE: line-state
+ { width float initial: 1.0 read-only }
+ { antialias? boolean initial: f read-only } ;
+C: <line-state> line-state
+
+UNION: gpu-state
+ viewport-state
+ triangle-cull-state
+ triangle-state
+ point-state
+ line-state
+ scissor-state
+ multisample-state
+ stencil-state
+ depth-range-state
+ depth-state
+ blend-state
+ mask-state ;
+
+<PRIVATE
+
+: gl-triangle-face ( triangle-face -- face )
+ {
+ { face-ccw [ GL_CCW ] }
+ { face-cw [ GL_CW ] }
+ } case ;
+
+: gl-triangle-face> ( triangle-face -- face )
+ {
+ { $ GL_CCW [ face-ccw ] }
+ { $ GL_CW [ face-cw ] }
+ } case ;
+
+: gl-triangle-cull ( triangle-cull -- cull )
+ {
+ { cull-front [ GL_FRONT ] }
+ { cull-back [ GL_BACK ] }
+ { cull-all [ GL_FRONT_AND_BACK ] }
+ } case ;
+
+: gl-triangle-cull> ( triangle-cull -- cull )
+ {
+ { $ GL_FRONT [ cull-front ] }
+ { $ GL_BACK [ cull-back ] }
+ { $ GL_FRONT_AND_BACK [ cull-all ] }
+ } case ;
+
+: gl-triangle-mode ( triangle-mode -- mode )
+ {
+ { triangle-points [ GL_POINT ] }
+ { triangle-lines [ GL_LINE ] }
+ { triangle-fill [ GL_FILL ] }
+ } case ;
+
+: gl-triangle-mode> ( triangle-mode -- mode )
+ {
+ { $ GL_POINT [ triangle-points ] }
+ { $ GL_LINE [ triangle-lines ] }
+ { $ GL_FILL [ triangle-fill ] }
+ } case ;
+
+: gl-point-sprite-origin ( point-sprite-origin -- sprite-origin )
+ {
+ { origin-upper-left [ GL_UPPER_LEFT ] }
+ { origin-lower-left [ GL_LOWER_LEFT ] }
+ } case ;
+
+: gl-point-sprite-origin> ( point-sprite-origin -- sprite-origin )
+ {
+ { $ GL_UPPER_LEFT [ origin-upper-left ] }
+ { $ GL_LOWER_LEFT [ origin-lower-left ] }
+ } case ;
+
+: gl-comparison ( comparison -- comparison )
+ {
+ { cmp-never [ GL_NEVER ] }
+ { cmp-always [ GL_ALWAYS ] }
+ { cmp-less [ GL_LESS ] }
+ { cmp-less-equal [ GL_LEQUAL ] }
+ { cmp-equal [ GL_EQUAL ] }
+ { cmp-greater-equal [ GL_GEQUAL ] }
+ { cmp-greater [ GL_GREATER ] }
+ { cmp-not-equal [ GL_NOTEQUAL ] }
+ } case ;
+
+: gl-comparison> ( comparison -- comparison )
+ {
+ { $ GL_NEVER [ cmp-never ] }
+ { $ GL_ALWAYS [ cmp-always ] }
+ { $ GL_LESS [ cmp-less ] }
+ { $ GL_LEQUAL [ cmp-less-equal ] }
+ { $ GL_EQUAL [ cmp-equal ] }
+ { $ GL_GEQUAL [ cmp-greater-equal ] }
+ { $ GL_GREATER [ cmp-greater ] }
+ { $ GL_NOTEQUAL [ cmp-not-equal ] }
+ } case ;
+
+: gl-stencil-op ( stencil-op -- op )
+ {
+ { op-keep [ GL_KEEP ] }
+ { op-zero [ GL_ZERO ] }
+ { op-replace [ GL_REPLACE ] }
+ { op-invert [ GL_INVERT ] }
+ { op-inc-sat [ GL_INCR ] }
+ { op-dec-sat [ GL_DECR ] }
+ { op-inc-wrap [ GL_INCR_WRAP ] }
+ { op-dec-wrap [ GL_DECR_WRAP ] }
+ } case ;
+
+: gl-stencil-op> ( op -- op )
+ {
+ { $ GL_KEEP [ op-keep ] }
+ { $ GL_ZERO [ op-zero ] }
+ { $ GL_REPLACE [ op-replace ] }
+ { $ GL_INVERT [ op-invert ] }
+ { $ GL_INCR [ op-inc-sat ] }
+ { $ GL_DECR [ op-dec-sat ] }
+ { $ GL_INCR_WRAP [ op-inc-wrap ] }
+ { $ GL_DECR_WRAP [ op-dec-wrap ] }
+ } case ;
+
+: (set-stencil-mode) ( gl-face stencil-mode -- )
+ {
+ [ [ comparison>> gl-comparison ] [ value>> ] [ mask>> ] tri glStencilFuncSeparate ]
+ [
+ [ stencil-fail-op>> ] [ depth-fail-op>> ] [ depth-pass-op>> ] tri
+ [ gl-stencil-op ] tri@ glStencilOpSeparate
+ ]
+ } 2cleave ;
+
+: gl-blend-equation ( blend-equation -- blend-equation )
+ {
+ { eq-add [ GL_FUNC_ADD ] }
+ { eq-subtract [ GL_FUNC_SUBTRACT ] }
+ { eq-reverse-subtract [ GL_FUNC_REVERSE_SUBTRACT ] }
+ { eq-min [ GL_MIN ] }
+ { eq-max [ GL_MAX ] }
+ } case ;
+
+: gl-blend-equation> ( blend-equation -- blend-equation )
+ {
+ { $ GL_FUNC_ADD [ eq-add ] }
+ { $ GL_FUNC_SUBTRACT [ eq-subtract ] }
+ { $ GL_FUNC_REVERSE_SUBTRACT [ eq-reverse-subtract ] }
+ { $ GL_MIN [ eq-min ] }
+ { $ GL_MAX [ eq-max ] }
+ } case ;
+
+: gl-blend-function ( blend-function -- blend-function )
+ {
+ { func-zero [ GL_ZERO ] }
+ { func-one [ GL_ONE ] }
+ { func-source [ GL_SRC_COLOR ] }
+ { func-one-minus-source [ GL_ONE_MINUS_SRC_COLOR ] }
+ { func-dest [ GL_DST_COLOR ] }
+ { func-one-minus-dest [ GL_ONE_MINUS_DST_COLOR ] }
+ { func-constant [ GL_CONSTANT_COLOR ] }
+ { func-one-minus-constant [ GL_ONE_MINUS_CONSTANT_COLOR ] }
+ { func-source-alpha [ GL_SRC_ALPHA ] }
+ { func-one-minus-source-alpha [ GL_ONE_MINUS_SRC_ALPHA ] }
+ { func-dest-alpha [ GL_DST_ALPHA ] }
+ { func-one-minus-dest-alpha [ GL_ONE_MINUS_DST_ALPHA ] }
+ { func-constant-alpha [ GL_CONSTANT_ALPHA ] }
+ { func-one-minus-constant-alpha [ GL_ONE_MINUS_CONSTANT_ALPHA ] }
+ { func-source-alpha-saturate [ GL_SRC_ALPHA_SATURATE ] }
+ } case ;
+
+: gl-blend-function> ( blend-function -- blend-function )
+ {
+ { $ GL_ZERO [ func-zero ] }
+ { $ GL_ONE [ func-one ] }
+ { $ GL_SRC_COLOR [ func-source ] }
+ { $ GL_ONE_MINUS_SRC_COLOR [ func-one-minus-source ] }
+ { $ GL_DST_COLOR [ func-dest ] }
+ { $ GL_ONE_MINUS_DST_COLOR [ func-one-minus-dest ] }
+ { $ GL_CONSTANT_COLOR [ func-constant ] }
+ { $ GL_ONE_MINUS_CONSTANT_COLOR [ func-one-minus-constant ] }
+ { $ GL_SRC_ALPHA [ func-source-alpha ] }
+ { $ GL_ONE_MINUS_SRC_ALPHA [ func-one-minus-source-alpha ] }
+ { $ GL_DST_ALPHA [ func-dest-alpha ] }
+ { $ GL_ONE_MINUS_DST_ALPHA [ func-one-minus-dest-alpha ] }
+ { $ GL_CONSTANT_ALPHA [ func-constant-alpha ] }
+ { $ GL_ONE_MINUS_CONSTANT_ALPHA [ func-one-minus-constant-alpha ] }
+ { $ GL_SRC_ALPHA_SATURATE [ func-source-alpha-saturate ] }
+ } case ;
+
+PRIVATE>
+
+GENERIC: set-gpu-state* ( state -- )
+
+M: viewport-state set-gpu-state*
+ rect>> [ loc>> first2 ] [ dim>> first2 ] bi glViewport ;
+
+M: triangle-cull-state set-gpu-state*
+ {
+ [ front-face>> gl-triangle-face glFrontFace ]
+ [ GL_CULL_FACE swap cull>> [ gl-triangle-cull glCullFace glEnable ] [ glDisable ] if* ]
+ } cleave ;
+
+M: triangle-state set-gpu-state*
+ {
+ [ GL_FRONT swap front-mode>> gl-triangle-mode glPolygonMode ]
+ [ GL_BACK swap back-mode>> gl-triangle-mode glPolygonMode ]
+ [ GL_POLYGON_SMOOTH swap antialias?>> [ glEnable ] [ glDisable ] if ]
+ } cleave ;
+
+M: point-state set-gpu-state*
+ {
+ [ GL_VERTEX_PROGRAM_POINT_SIZE swap size>> [ glPointSize glDisable ] [ glEnable ] if* ]
+ [ GL_POINT_SPRITE_COORD_ORIGIN swap sprite-origin>> gl-point-sprite-origin glPointParameteri ]
+ [ GL_POINT_FADE_THRESHOLD_SIZE swap fade-threshold>> glPointParameterf ]
+ } cleave ;
+
+M: line-state set-gpu-state*
+ {
+ [ width>> glLineWidth ]
+ [ GL_LINE_SMOOTH swap antialias?>> [ glEnable ] [ glDisable ] if ]
+ } cleave ;
+
+M: scissor-state set-gpu-state*
+ GL_SCISSOR_TEST swap rect>>
+ [ [ loc>> first2 ] [ dim>> first2 ] bi glViewport glEnable ]
+ [ glDisable ] if* ;
+
+M: multisample-state set-gpu-state*
+ dup multisample?>> [
+ GL_MULTISAMPLE glEnable
+ {
+ [ GL_SAMPLE_ALPHA_TO_COVERAGE swap sample-alpha-to-coverage?>>
+ [ glEnable ] [ glDisable ] if
+ ]
+ [ GL_SAMPLE_ALPHA_TO_ONE swap sample-alpha-to-one?>>
+ [ glEnable ] [ glDisable ] if
+ ]
+ [ GL_SAMPLE_COVERAGE swap [ invert-sample-coverage?>> >c-bool ] [ sample-coverage>> ] bi
+ [ swap glSampleCoverage glEnable ] [ drop glDisable ] if*
+ ]
+ } cleave
+ ] [ drop GL_MULTISAMPLE glDisable ] if ;
+
+M: stencil-state set-gpu-state*
+ [ ] [ front-mode>> ] [ back-mode>> ] tri or
+ [
+ GL_STENCIL_TEST glEnable
+ [ front-mode>> GL_FRONT swap (set-stencil-mode) ]
+ [ back-mode>> GL_BACK swap (set-stencil-mode) ] bi
+ ] [ drop GL_STENCIL_TEST glDisable ] if ;
+
+M: depth-range-state set-gpu-state*
+ [ near>> ] [ far>> ] bi glDepthRange ;
+
+M: depth-state set-gpu-state*
+ GL_DEPTH_TEST swap comparison>> [ gl-comparison glDepthFunc glEnable ] [ glDisable ] if* ;
+
+M: blend-state set-gpu-state*
+ [ ] [ rgb-mode>> ] [ alpha-mode>> ] tri or
+ [
+ GL_BLEND glEnable
+ [ constant-color>> [ first4 glBlendColor ] when* ]
+ [
+ [ rgb-mode>> ] [ alpha-mode>> ] bi {
+ [ [ equation>> gl-blend-equation ] bi@ glBlendEquationSeparate ]
+ [
+ [
+ [ source-function>> gl-blend-function ]
+ [ dest-function>> gl-blend-function ] bi
+ ] bi@ glBlendFuncSeparate
+ ]
+ } 2cleave
+ ] bi
+ ] [ drop GL_BLEND glDisable ] if ;
+
+M: mask-state set-gpu-state*
+ {
+ [ color>> [ >c-bool ] map first4 glColorMask ]
+ [ depth>> >c-bool glDepthMask ]
+ [ GL_FRONT swap stencil-front>> glStencilMaskSeparate ]
+ [ GL_BACK swap stencil-back>> glStencilMaskSeparate ]
+ } cleave ;
+
+: set-gpu-state ( states -- )
+ dup sequence?
+ [ [ set-gpu-state* ] each ]
+ [ set-gpu-state* ] if ; inline
+
+<PRIVATE
+
+: get-gl-bool ( enum -- value )
+ 0 <uchar> [ glGetBooleanv ] keep *uchar c-bool> ;
+: get-gl-int ( enum -- value )
+ 0 <int> [ glGetIntegerv ] keep *int ;
+: get-gl-float ( enum -- value )
+ 0 <float> [ glGetFloatv ] keep *float ;
+
+: get-gl-bools ( enum count -- value )
+ <byte-array> [ glGetBooleanv ] keep [ c-bool> ] { } map-as ;
+: get-gl-ints ( enum count -- value )
+ <int-array> [ glGetIntegerv ] keep ;
+: get-gl-floats ( enum count -- value )
+ <float-array> [ glGetFloatv ] keep ;
+
+: get-gl-rect ( enum -- value )
+ 4 get-gl-ints first4 [ 2array ] 2bi@ <rect> ;
+
+: gl-enabled? ( enum -- ? )
+ glIsEnabled c-bool> ;
+
+PRIVATE>
+
+: get-viewport-state ( -- viewport-state )
+ GL_VIEWPORT get-gl-rect <viewport-state> ;
+
+: get-scissor-state ( -- scissor-state )
+ GL_SCISSOR_TEST get-gl-bool
+ [ GL_SCISSOR_BOX get-gl-rect ] [ f ] if
+ <scissor-state> ;
+
+: get-multisample-state ( -- multisample-state )
+ GL_MULTISAMPLE gl-enabled?
+ GL_SAMPLE_ALPHA_TO_COVERAGE gl-enabled?
+ GL_SAMPLE_ALPHA_TO_ONE gl-enabled?
+ GL_SAMPLE_COVERAGE gl-enabled? [
+ GL_SAMPLE_COVERAGE_VALUE get-gl-float
+ GL_SAMPLE_COVERAGE_INVERT get-gl-bool
+ ] [ f f ] if
+ <multisample-state> ;
+
+: get-stencil-state ( -- stencil-state )
+ GL_STENCIL_TEST gl-enabled? [
+ GL_STENCIL_REF get-gl-int
+ GL_STENCIL_VALUE_MASK get-gl-int
+ GL_STENCIL_FUNC get-gl-int gl-comparison>
+ GL_STENCIL_FAIL get-gl-int gl-stencil-op>
+ GL_STENCIL_PASS_DEPTH_FAIL get-gl-int gl-stencil-op>
+ GL_STENCIL_PASS_DEPTH_PASS get-gl-int gl-stencil-op>
+ <stencil-mode>
+
+ GL_STENCIL_BACK_REF get-gl-int
+ GL_STENCIL_BACK_VALUE_MASK get-gl-int
+ GL_STENCIL_BACK_FUNC get-gl-int gl-comparison>
+ GL_STENCIL_BACK_FAIL get-gl-int gl-stencil-op>
+ GL_STENCIL_BACK_PASS_DEPTH_FAIL get-gl-int gl-stencil-op>
+ GL_STENCIL_BACK_PASS_DEPTH_PASS get-gl-int gl-stencil-op>
+ <stencil-mode>
+ ] [ f f ] if
+ <stencil-state> ;
+
+: get-depth-range-state ( -- depth-range-state )
+ GL_DEPTH_RANGE 2 get-gl-floats first2 <depth-range-state> ;
+
+: get-depth-state ( -- depth-state )
+ GL_DEPTH_TEST gl-enabled?
+ [ GL_DEPTH_FUNC get-gl-int gl-comparison> ] [ f ] if
+ <depth-state> ;
+
+: get-blend-state ( -- blend-state )
+ GL_BLEND gl-enabled? [
+ GL_BLEND_COLOR 4 get-gl-floats
+
+ GL_BLEND_EQUATION_RGB get-gl-int gl-blend-equation>
+ GL_BLEND_SRC_RGB get-gl-int gl-blend-function>
+ GL_BLEND_DST_RGB get-gl-int gl-blend-function>
+ <blend-mode>
+
+ GL_BLEND_EQUATION_ALPHA get-gl-int gl-blend-equation>
+ GL_BLEND_SRC_ALPHA get-gl-int gl-blend-function>
+ GL_BLEND_DST_ALPHA get-gl-int gl-blend-function>
+ <blend-mode>
+ ] [ f f f ] if
+ <blend-state> ;
+
+: get-mask-state ( -- mask-state )
+ GL_COLOR_WRITEMASK 4 get-gl-bools
+ GL_DEPTH_WRITEMASK get-gl-bool
+ GL_STENCIL_WRITEMASK get-gl-int
+ GL_STENCIL_BACK_WRITEMASK get-gl-int
+ <mask-state> ;
+
+: get-triangle-cull-state ( -- triangle-cull-state )
+ GL_FRONT_FACE get-gl-int gl-triangle-face>
+ GL_CULL_FACE gl-enabled?
+ [ GL_CULL_FACE_MODE get-gl-int gl-triangle-cull> ]
+ [ f ] if
+ <triangle-cull-state> ;
+
+: get-triangle-state ( -- triangle-state )
+ GL_POLYGON_MODE 2 get-gl-ints
+ first2 [ gl-triangle-mode> ] bi@
+ GL_POLYGON_SMOOTH gl-enabled?
+ <triangle-state> ;
+
+: get-point-state ( -- point-state )
+ GL_VERTEX_PROGRAM_POINT_SIZE gl-enabled?
+ [ f ] [ GL_POINT_SIZE get-gl-float ] if
+ GL_POINT_SPRITE_COORD_ORIGIN get-gl-int gl-point-sprite-origin>
+ GL_POINT_FADE_THRESHOLD_SIZE get-gl-float
+ <point-state> ;
+
+: get-line-state ( -- line-state )
+ GL_LINE_WIDTH get-gl-float
+ GL_LINE_SMOOTH gl-enabled?
+ <line-state> ;
--- /dev/null
+GPU state manipulation
--- /dev/null
+High-level OpenGL-based GPU resource management and rendering library
--- /dev/null
+Multidimensional image data in GPU memory
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: byte-arrays classes gpu.buffers help.markup help.syntax
+images kernel math ;
+IN: gpu.textures
+
+HELP: +X
+{ $class-description "This " { $link cube-map-axis } " references the positive X face of a " { $link texture-cube-map } "." } ;
+
+HELP: +Y
+{ $class-description "This " { $link cube-map-axis } " references the positive Y face of a " { $link texture-cube-map } "." } ;
+
+HELP: +Z
+{ $class-description "This " { $link cube-map-axis } " references the positive Z face of a " { $link texture-cube-map } "." } ;
+
+HELP: -X
+{ $class-description "This " { $link cube-map-axis } " references the negative X face of a " { $link texture-cube-map } "." } ;
+
+HELP: -Y
+{ $class-description "This " { $link cube-map-axis } " references the negative Y face of a " { $link texture-cube-map } "." } ;
+
+HELP: -Z
+{ $class-description "This " { $link cube-map-axis } " references the negative Z face of a " { $link texture-cube-map } "." } ;
+
+HELP: <cube-map-face>
+{ $values
+ { "texture" texture-cube-map } { "axis" cube-map-axis }
+ { "cube-map-face" cube-map-face }
+}
+{ $description "Constructs a new " { $link cube-map-face } " reference." } ;
+
+HELP: <texture-1d-array>
+{ $values
+ { "component-order" component-order } { "component-type" component-type } { "parameters" texture-parameters }
+ { "texture" texture-1d-array }
+}
+{ $description "Creates a new one-dimensional array texture. The new texture starts out with no image data; " { $link allocate-texture } " or " { $link allocate-texture-image } " must be used to allocate memory for the required levels of detail of the texture." }
+{ $notes "Array textures require OpenGL 3.0 or the " { $snippet "GL_EXT_texture_array" } " extension." } ;
+
+HELP: <texture-1d>
+{ $values
+ { "component-order" component-order } { "component-type" component-type } { "parameters" texture-parameters }
+ { "texture" texture-1d }
+}
+{ $description "Creates a new one-dimensional texture. The new texture starts out with no image data; " { $link allocate-texture } " or " { $link allocate-texture-image } " must be used to allocate memory for the required levels of detail of the texture." } ;
+
+HELP: <texture-2d-array>
+{ $values
+ { "component-order" component-order } { "component-type" component-type } { "parameters" texture-parameters }
+ { "texture" texture-2d-array }
+}
+{ $description "Creates a new two-dimensional array texture. The new texture starts out with no image data; " { $link allocate-texture } " or " { $link allocate-texture-image } " must be used to allocate memory for the required levels of detail of the texture." }
+{ $notes "Array textures require OpenGL 3.0 or the " { $snippet "GL_EXT_texture_array" } " extension." } ;
+
+HELP: <texture-2d>
+{ $values
+ { "component-order" component-order } { "component-type" component-type } { "parameters" texture-parameters }
+ { "texture" texture-2d }
+}
+{ $description "Creates a new two-dimensional texture. The new texture starts out with no image data; " { $link allocate-texture } " or " { $link allocate-texture-image } " must be used to allocate memory for the required levels of detail of the texture." } ;
+
+HELP: <texture-3d>
+{ $values
+ { "component-order" component-order } { "component-type" component-type } { "parameters" texture-parameters }
+ { "texture" texture-3d }
+}
+{ $description "Creates a new three-dimensional texture. The new texture starts out with no image data; " { $link allocate-texture } " or " { $link allocate-texture-image } " must be used to allocate memory for the required levels of detail of the texture." } ;
+
+HELP: <texture-cube-map>
+{ $values
+ { "component-order" component-order } { "component-type" component-type } { "parameters" texture-parameters }
+ { "texture" texture-cube-map }
+}
+{ $description "Creates a new cube map texture. The new texture starts out with no image data; " { $link allocate-texture } " or " { $link allocate-texture-image } " must be used to allocate memory for the required levels of detail of each " { $link cube-map-face } " of the new texture." } ;
+
+HELP: <texture-data>
+{ $values
+ { "ptr" gpu-data-ptr } { "component-order" component-order } { "component-type" component-type }
+ { "texture-data" texture-data }
+}
+{ $description "Constructs a new " { $link texture-data } " tuple." }
+{ $notes "Using a " { $link buffer-ptr } " as the " { $snippet "ptr" } " of a " { $snippet "texture-data" } " object requires OpenGL 2.1 or later or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+HELP: <texture-rectangle>
+{ $values
+ { "component-order" component-order } { "component-type" component-type } { "parameters" texture-parameters }
+ { "texture" texture-rectangle }
+}
+{ $description "Creates a new rectangle texture. The new texture starts out with no image data; " { $link allocate-texture } " or " { $link allocate-texture-image } " must be used to allocate memory for the texture." }
+{ $notes "Rectangle textures require OpenGL 3.1 or the " { $snippet "GL_ARB_texture_rectangle" } " extension." } ;
+
+HELP: allocate-texture
+{ $values
+ { "tdt" texture-data-target } { "level" integer } { "dim" "an " { $link integer } " or sequence of " { $link integer } "s" } { "data" { $maybe texture-data } }
+}
+{ $description "Allocates a new block of GPU memory for the " { $snippet "level" } "th level of detail of a " { $link texture-data-target } ". If " { $snippet "data" } " is not " { $link f } ", the new data is initialized from the given " { $link texture-data } " object; otherwise, the new image is left uninitialized." }
+{ $notes "Using a " { $link buffer-ptr } " as the " { $snippet "ptr" } " of a " { $snippet "texture-data" } " object requires OpenGL 2.1 or later or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+HELP: allocate-texture-image
+{ $values
+ { "tdt" texture-data-target } { "level" integer } { "image" image }
+}
+{ $description "Allocates a new block of GPU memory for the " { $snippet "level" } "th level of detail of a " { $link texture-data-target } " and initializes it with the contents of an " { $link image } "." } ;
+
+{ allocate-texture allocate-texture-image } related-words
+
+HELP: clamp-texcoord-to-border
+{ $class-description "This " { $link texture-wrap } " value clamps texture coordinates to a texture's border." } ;
+
+HELP: clamp-texcoord-to-edge
+{ $class-description "This " { $link texture-wrap } " value clamps texture coordinates to a texture image's edge." } ;
+
+HELP: cube-map-axis
+{ $class-description "Objects of this class are stored in the " { $snippet "axis" } " slot of a " { $link cube-map-face } " to choose the referenced face: " { $link +X } ", " { $link +Y } ", " { $link +Z } ", " { $link -X } ", " { $link -Y } ", or " { $link -Z } "."
+} ;
+
+HELP: cube-map-face
+{ $class-description "A " { $snippet "cube-map-face" } " tuple references a single face of a " { $link texture-cube-map } " object for use with " { $link allocate-texture } ", " { $link update-texture } ", or " { $link read-texture } "."
+{ $list
+{ "The " { $snippet "texture" } " slot indicates the cube map texture being referenced." }
+{ "The " { $snippet "axis" } " slot indicates which face to reference: " { $link +X } ", " { $link +Y } ", " { $link +Z } ", " { $link -X } ", " { $link -Y } ", or " { $link -Z } "." }
+} } ;
+
+HELP: filter-linear
+{ $class-description "This " { $link texture-filter } " value selects linear filtering between pixel samples." } ;
+
+HELP: filter-nearest
+{ $class-description "This " { $link texture-filter } " value selects nearest-neighbor sampling." } ;
+
+HELP: generate-mipmaps
+{ $values
+ { "texture" texture }
+}
+{ $description "Replaces the image data for all levels of detail of " { $snippet "texture" } " below the highest level with images automatically generated from the highest level of detail image." }
+{ $notes "This word requires OpenGL 3.0 or one of the " { $snippet "GL_EXT_framebuffer_object" } " or " { $snippet "GL_ARB_framebuffer_object" } " extensions." } ;
+
+HELP: image>texture-data
+{ $values
+ { "image" image }
+ { "dim" "a sequence of " { $link integer } "s" } { "texture-data" texture-data }
+}
+{ $description "Constructs a " { $link texture-data } " tuple referencing the pixel data from an " { $link image } "." } ;
+
+HELP: read-texture
+{ $values
+ { "tdt" texture-data-target } { "level" integer }
+ { "byte-array" byte-array }
+}
+{ $description "Reads the entire image for the " { $snippet "level" } "th level of detail of a texture into a new " { $link byte-array } ". The format of the data in the byte array is determined by the " { $link component-order } " and " { $link component-type } " of the texture." } ;
+
+HELP: read-texture-image
+{ $values
+ { "tdt" texture-data-target } { "level" integer }
+ { "image" image }
+}
+{ $description "Reads the entire image for the " { $snippet "level" } "th level of detail of a texture into a new " { $link image } ". The format of the image is determined by the " { $link component-order } " and " { $link component-type } " of the texture." } ;
+
+HELP: read-texture-to
+{ $values
+ { "tdt" texture-data-target } { "level" integer } { "gpu-data-ptr" gpu-data-ptr }
+}
+{ $description "Reads the entire image for the " { $snippet "level" } "th level of detail of a texture into the CPU or GPU memory referenced by " { $link gpu-data-ptr } ". The format of the data in the byte array is determined by the " { $link component-order } " and " { $link component-type } " of the texture." }
+{ $notes "Reading texture data into a GPU " { $snippet "buffer-ptr" } " requires OpenGL 2.1 or later or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+{ read-texture read-texture-image read-texture-to } related-words
+
+HELP: repeat-texcoord
+{ $class-description "This " { $link texture-wrap } " value causes the texture image to be repeated through texture coordinate space." } ;
+
+HELP: repeat-texcoord-mirrored
+{ $class-description "This " { $link texture-wrap } " value causes the texture image to be repeated through texture coordinate space, mirroring the image on every repetition." } ;
+
+HELP: set-texture-parameters
+{ $values
+ { "texture" texture } { "parameters" texture-parameters }
+}
+{ $description "Changes the " { $link texture-parameters } " of a " { $link texture } "." } ;
+
+HELP: texture
+{ $class-description "Textures are typed, multidimensional arrays of GPU memory used for storing image data, lookup tables, and other kinds of multidimensional data for use with shader programs. They come in different types depending on dimensionality and intended usage:"
+{ $subsection texture-1d }
+{ $subsection texture-2d }
+{ $subsection texture-3d }
+{ $subsection texture-cube-map }
+{ $subsection texture-rectangle }
+{ $subsection texture-1d-array }
+{ $subsection texture-2d-array }
+"Textures are constructed using the corresponding " { $snippet "<constructor word>" } " for their type. The constructor sets the texture's " { $link component-order } ", " { $link component-type } ", and " { $link texture-parameters } ". Once created, memory for a texture can be allocated with " { $link allocate-texture } ", updated with " { $link update-texture } ", or retrieved with " { $link read-texture } "." } ;
+
+HELP: texture-1d
+{ $class-description "A one-dimensional " { $link texture } " object. Textures of this type are dimensioned by single integers in calls to " { $link allocate-texture } " and " { $link update-texture } "." } ;
+
+{ texture-1d <texture-1d> } related-words
+
+HELP: texture-1d-array
+{ $class-description "A one-dimensional array " { $link texture } " object. Textures of this type are dimensioned by pairs of integers in calls to " { $link allocate-texture } " and " { $link update-texture } ". A 1D array texture is distinct from a 2D texture (" { $link texture-2d } ") in that each row of the texture is independent; texture values are not filtered between rows, and lower levels of detail retain the same height, only losing detail in the width direction." }
+{ $notes "Array textures require OpenGL 3.0 or the " { $snippet "GL_EXT_texture_array" } " extension." } ;
+
+{ texture-1d-array <texture-1d-array> } related-words
+
+HELP: texture-2d
+{ $class-description "A two-dimensional " { $link texture } " object. Textures of this type are dimensioned by pairs of integers in calls to " { $link allocate-texture } " and " { $link update-texture } "." } ;
+
+{ texture-2d <texture-2d> } related-words
+
+HELP: texture-2d-array
+{ $class-description "A two-dimensional array " { $link texture } " object. Textures of this type are dimensioned by sequences of three integers in calls to " { $link allocate-texture } " and " { $link update-texture } ". A 2D array texture is distinct from a 3D texture (" { $link texture-3d } ") in that each plane of the texture is independent; texture values are not filtered between planes, and lower levels of detail retain the same depth, only losing detail in the width and height directions." }
+{ $notes "Array textures require OpenGL 3.0 or the " { $snippet "GL_EXT_texture_array" } " extension." } ;
+
+{ texture-2d-array <texture-2d-array> } related-words
+
+HELP: texture-3d
+{ $class-description "A three-dimensional " { $link texture } " object. Textures of this type are dimensioned by sequences of three integers in calls to " { $link allocate-texture } " and " { $link update-texture } "." } ;
+
+{ texture-3d <texture-3d> } related-words
+
+HELP: texture-wrap
+{ $class-description "Values of this class are used in the " { $snippet "wrap" } " slot of a set of " { $link texture-parameters } " to specify how texture coordinates outside the 0.0 to 1.0 range should be mapped onto the texture image."
+{ $list
+{ { $link clamp-texcoord-to-edge } " clamps coordinates to the edge of the texture image." }
+{ { $link clamp-texcoord-to-border } " clamps coordinates to the border of the texture image." }
+{ { $link repeat-texcoord } " repeats the texture image." }
+{ { $link repeat-texcoord-mirrored } " repeats the texture image, mirroring it with each repetition." }
+} } ;
+
+HELP: texture-cube-map
+{ $class-description "A cube map " { $link texture } " object. Textures of this type comprise six two-dimensional image sets, which are independently referenced by " { $link cube-map-face } " objects and dimensioned by pairs of integers in calls to " { $link allocate-texture } " and " { $link update-texture } ". When a cube map is sampled in shader code, the three-dimensional texture coordinates are projected onto the unit cube, and the cube face that is hit by the vector is used to select a face of the cube map texture." } ;
+
+{ texture-cube-map <texture-cube-map> } related-words
+
+HELP: texture-data
+{ $class-description { $snippet "texture-data" } " tuples are used to feed image data to " { $link allocate-texture } " and " { $link update-texture } ". In addition to providing a " { $snippet "ptr" } " to CPU memory or a GPU " { $link buffer-ptr } ", the " { $link texture-data } " object also specifies the " { $link component-order } " and " { $link component-type } " of the referenced data." }
+{ $notes "Using a " { $link buffer-ptr } " as the " { $snippet "ptr" } " of a " { $snippet "texture-data" } " object requires OpenGL 2.1 or later or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+{ texture-data <texture-data> } related-words
+
+HELP: texture-data-size
+{ $values
+ { "tdt" texture-data-target } { "level" integer }
+ { "size" integer }
+}
+{ $description "Returns the size in bytes of the image data allocated for the " { $snippet "level" } "th level of detail of a " { $link texture-data-target } "." } ;
+
+HELP: texture-data-target
+{ $class-description "Most " { $link texture } " types can have image data assigned to themselves directly by " { $link allocate-texture } " and " { $link update-texture } "; however, " { $link texture-cube-map } " objects comprise six independent image sets, each of which must be referenced separately with a " { $link cube-map-face } " tuple when allocating or updating images. The " { $snippet "texture-data-target" } " class is a union of all " { $link texture } " classes (except " { $snippet "texture-cube-map" } ") and the " { $snippet "cube-map-face" } " class." } ;
+
+HELP: texture-dim
+{ $values
+ { "tdt" texture-data-target } { "level" integer }
+ { "dim" "an " { $link integer } " or sequence of integers" }
+}
+{ $description "Returns the dimensions of the memory allocated for the " { $snippet "level" } "th level of detail of the given " { $link texture-data-target } "." } ;
+
+HELP: texture-filter
+{ $class-description { $snippet "texture-filter" } " values are used in a " { $link texture-parameters } " tuple to determine how a texture should be sampled between pixels or between levels of detail. " { $link filter-linear } " selects linear filtering, while " { $link filter-nearest } " selects nearest-neighbor sampling." } ;
+
+HELP: texture-parameters
+{ $class-description "When a " { $link texture } " is created, the following " { $snippet "texture-parameter" } "s are set to control how the texture is sampled:"
+{ $list
+{ "The " { $snippet "wrap" } " slot determines how texture coordinates outside the 0.0 to 1.0 range are mapped to the texture image. The slot either contains a single " { $link texture-wrap } " value, which will apply to all three axes, or a sequence of up to three values, which will apply to the S, T, and R axes, respectively." }
+{ "The " { $snippet "min-filter" } " and " { $snippet "min-mipmap-filter" } " determine how the texture image is filtered when sampled below its highest level of detail, the former controlling filtering between pixels within a level of detail and the latter filtering between levels of detail. A setting of " { $link filter-linear } " uses linear, bilinear, or trilinear filtering among sampled pixels, while a setting of " { $link filter-nearest } " uses nearest-neighbor sampling. The " { $snippet "min-mipmap-filter" } " slot may additionally be set to " { $link f } " to disable mipmapping and only sample the highest level of detail." }
+{ "The " { $snippet "mag-filter" } " analogously determines how the texture image is filtered when sampled above its highest level of detail." }
+{ "The " { $snippet "min-lod" } " and " { $snippet "max-lod" } " slots contain integer values that will clamp the range of levels of detail that will be sampled from the texture." }
+{ "The " { $snippet "lod-bias" } " slot contains an integer value that will offset the levels of detail that would normally be sampled from the texture." }
+{ "The " { $snippet "base-level" } " slot contains an integer value that identifies the highest level of detail for the image, typically zero." }
+{ "The " { $snippet "max-level" } " slot contains an integer value that identifies the lowest level of detail for the image. This value will automatically be clamped to the maximum of the base-2 logarithm of the dimensions of the highest level of detail image." }
+} } ;
+
+{ texture-parameters set-texture-parameters } related-words
+
+HELP: texture-rectangle
+{ $class-description "A two-dimensional rectangle " { $link texture } " object. Textures of this type are dimensioned by pairs of integers in calls to " { $link allocate-texture } " and " { $link update-texture } ". Rectangle textures differ from normal 2D textures (" { $link texture-2d } ") in that texture coordinates map directly to pixel coordinates when they are sampled from shader code, rather than being normalized into the 0.0 to 1.0 range as with other texture types. Also, rectangle textures do not support mipmapping or texture wrapping." }
+{ $notes "Rectangle textures require OpenGL 3.1 or the " { $snippet "GL_ARB_texture_rectangle" } " extension." } ;
+
+HELP: update-texture
+{ $values
+ { "tdt" texture-data-target } { "level" integer } { "loc" "an " { $link integer } " or sequence of integers" } { "dim" "an " { $link integer } " or sequence of integers" } { "data" texture-data }
+}
+{ $description "Updates the linear, rectangular, or cubic subregion of a " { $link texture-data-target } " bounded by " { $snippet "loc" } " and " { $snippet "dim" } " with new image data from a " { $link texture-data } " tuple." }
+{ $notes "Using a " { $link buffer-ptr } " as the " { $snippet "ptr" } " of a " { $snippet "texture-data" } " object requires OpenGL 2.1 or later or the " { $snippet "GL_ARB_pixel_buffer_object" } " extension." } ;
+
+HELP: update-texture-image
+{ $values
+ { "tdt" texture-data-target } { "level" integer } { "loc" "an " { $link integer } " or sequence of integers" } { "image" image }
+}
+{ $description "Updates the linear, rectangular, or cubic subregion of a " { $link texture-data-target } " bounded by " { $snippet "loc" } " and " { $snippet "dim" } " with new image data from an " { $link image } " object." } ;
+
+{ update-texture update-texture-image } related-words
+
+ARTICLE: "gpu.textures" "Texture objects"
+"The " { $vocab-link "gpu.textures" } " vocabulary provides words for creating, allocating, updating, and reading GPU texture objects."
+{ $subsection texture }
+{ $subsection allocate-texture }
+{ $subsection update-texture }
+{ $subsection read-texture }
+"Words are also provided to interface textures with the " { $vocab-link "images" } " library:"
+{ $subsection allocate-texture-image }
+{ $subsection update-texture-image }
+{ $subsection read-texture-image }
+;
+
+ABOUT: "gpu.textures"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+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 ;
+IN: gpu.textures
+
+TUPLE: texture < gpu-object
+ { component-order component-order read-only initial: RGBA }
+ { component-type component-type read-only initial: ubyte-components } ;
+
+TUPLE: texture-1d < texture ;
+TUPLE: texture-2d < texture ;
+TUPLE: texture-rectangle < texture ;
+TUPLE: texture-3d < texture ;
+TUPLE: texture-cube-map < texture ;
+
+TUPLE: texture-1d-array < texture ;
+TUPLE: texture-2d-array < texture ;
+
+VARIANT: cube-map-axis
+ -X -Y -Z +X +Y +Z ;
+
+TUPLE: cube-map-face
+ { texture texture-cube-map read-only }
+ { axis cube-map-axis read-only } ;
+C: <cube-map-face> cube-map-face
+
+UNION: texture-data-target
+ texture-1d texture-2d texture-3d cube-map-face ;
+UNION: texture-1d-data-target
+ texture-1d ;
+UNION: texture-2d-data-target
+ texture-2d texture-rectangle texture-1d-array cube-map-face ;
+UNION: texture-3d-data-target
+ texture-3d texture-2d-array ;
+
+M: texture dispose
+ [ [ delete-texture ] when* f ] change-handle drop ;
+
+TUPLE: texture-data
+ { ptr read-only }
+ { component-order component-order read-only initial: RGBA }
+ { component-type component-type read-only initial: ubyte-components } ;
+
+C: <texture-data> texture-data
+UNION: ?texture-data texture-data POSTPONE: f ;
+UNION: ?float-array float-array POSTPONE: f ;
+
+VARIANT: texture-wrap
+ clamp-texcoord-to-edge clamp-texcoord-to-border repeat-texcoord repeat-texcoord-mirrored ;
+VARIANT: texture-filter
+ filter-nearest filter-linear ;
+
+UNION: wrap-set texture-wrap sequence ;
+UNION: ?texture-filter texture-filter POSTPONE: f ;
+
+TUPLE: texture-parameters
+ { wrap wrap-set initial: { repeat-texcoord repeat-texcoord repeat-texcoord } }
+ { min-filter texture-filter initial: filter-nearest }
+ { min-mipmap-filter ?texture-filter initial: filter-linear }
+ { mag-filter texture-filter initial: filter-linear }
+ { min-lod integer initial: -1000 }
+ { max-lod integer initial: 1000 }
+ { lod-bias integer initial: 0 }
+ { base-level integer initial: 0 }
+ { max-level integer initial: 1000 } ;
+
+<PRIVATE
+
+GENERIC: texture-object ( texture-data-target -- texture )
+M: cube-map-face texture-object
+ texture>> ;
+M: texture texture-object
+ ;
+
+: gl-wrap ( wrap -- gl-wrap )
+ {
+ { clamp-texcoord-to-edge [ GL_CLAMP_TO_EDGE ] }
+ { clamp-texcoord-to-border [ GL_CLAMP_TO_BORDER ] }
+ { repeat-texcoord [ GL_REPEAT ] }
+ { repeat-texcoord-mirrored [ GL_MIRRORED_REPEAT ] }
+ } case ;
+
+: set-texture-gl-wrap ( target wraps -- )
+ dup sequence? [ 1array ] unless 3 over last pad-tail {
+ [ [ GL_TEXTURE_WRAP_S ] dip first gl-wrap glTexParameteri ]
+ [ [ GL_TEXTURE_WRAP_T ] dip second gl-wrap glTexParameteri ]
+ [ [ GL_TEXTURE_WRAP_R ] dip third gl-wrap glTexParameteri ]
+ } 2cleave ;
+
+: gl-mag-filter ( filter -- gl-filter )
+ {
+ { filter-nearest [ GL_NEAREST ] }
+ { filter-linear [ GL_LINEAR ] }
+ } case ;
+
+: gl-min-filter ( filter mipmap-filter -- gl-filter )
+ 2array {
+ { { filter-nearest f } [ GL_NEAREST ] }
+ { { filter-linear f } [ GL_LINEAR ] }
+ { { filter-nearest filter-nearest } [ GL_NEAREST_MIPMAP_NEAREST ] }
+ { { filter-linear filter-nearest } [ GL_LINEAR_MIPMAP_NEAREST ] }
+ { { filter-linear filter-linear } [ GL_LINEAR_MIPMAP_LINEAR ] }
+ { { filter-nearest filter-linear } [ GL_NEAREST_MIPMAP_LINEAR ] }
+ } case ;
+
+GENERIC: texture-gl-target ( texture -- target )
+GENERIC: texture-data-gl-target ( texture -- target )
+
+M: texture-1d texture-gl-target drop GL_TEXTURE_1D ;
+M: texture-2d texture-gl-target drop GL_TEXTURE_2D ;
+M: texture-rectangle texture-gl-target drop GL_TEXTURE_RECTANGLE ;
+M: texture-3d texture-gl-target drop GL_TEXTURE_3D ;
+M: texture-cube-map texture-gl-target drop GL_TEXTURE_CUBE_MAP ;
+M: texture-1d-array texture-gl-target drop GL_TEXTURE_1D_ARRAY ;
+M: texture-2d-array texture-gl-target drop GL_TEXTURE_2D_ARRAY ;
+
+M: texture-1d texture-data-gl-target drop GL_TEXTURE_1D ;
+M: texture-2d texture-data-gl-target drop GL_TEXTURE_2D ;
+M: texture-rectangle texture-data-gl-target drop GL_TEXTURE_RECTANGLE ;
+M: texture-3d texture-data-gl-target drop GL_TEXTURE_3D ;
+M: texture-1d-array texture-data-gl-target drop GL_TEXTURE_1D_ARRAY ;
+M: texture-2d-array texture-data-gl-target drop GL_TEXTURE_2D_ARRAY ;
+M: cube-map-face texture-data-gl-target
+ axis>> {
+ { -X [ GL_TEXTURE_CUBE_MAP_NEGATIVE_X ] }
+ { -Y [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Y ] }
+ { -Z [ GL_TEXTURE_CUBE_MAP_NEGATIVE_Z ] }
+ { +X [ GL_TEXTURE_CUBE_MAP_POSITIVE_X ] }
+ { +Y [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y ] }
+ { +Z [ GL_TEXTURE_CUBE_MAP_POSITIVE_Z ] }
+ } case ;
+
+: texture-gl-internal-format ( texture -- internal-format )
+ [ component-order>> ] [ component-type>> ] bi image-internal-format ; inline
+
+: texture-data-gl-args ( texture data -- format type ptr )
+ [
+ nip
+ [ [ component-order>> ] [ component-type>> ] bi image-data-format ]
+ [ ptr>> ] bi
+ ] [
+ [ component-order>> ] [ component-type>> ] bi image-data-format f
+ ] if* ;
+
+:: bind-tdt ( tdt -- texture )
+ tdt texture-object :> texture
+ texture [ texture-gl-target ] [ handle>> ] bi glBindTexture
+ texture ;
+
+: get-texture-float ( target level enum -- value )
+ 0 <float> [ glGetTexLevelParameterfv ] keep *float ;
+: get-texture-int ( texture level enum -- value )
+ 0 <int> [ glGetTexLevelParameteriv ] keep *int ;
+
+: ?product ( x -- y )
+ dup number? [ product ] unless ;
+
+PRIVATE>
+
+GENERIC# allocate-texture 3 ( tdt level dim data -- )
+
+M:: texture-1d-data-target allocate-texture ( tdt level dim data -- )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level texture texture-gl-internal-format
+ dim 0 texture data texture-data-gl-args
+ pixel-unpack-buffer [ glTexImage1D ] with-gpu-data-ptr ;
+
+M:: texture-2d-data-target allocate-texture ( tdt level dim data -- )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level texture texture-gl-internal-format
+ dim first2 0 texture data texture-data-gl-args
+ pixel-unpack-buffer [ glTexImage2D ] with-gpu-data-ptr ;
+
+M:: texture-3d-data-target allocate-texture ( tdt level dim data -- )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level texture texture-gl-internal-format
+ dim first3 0 texture data texture-data-gl-args
+ pixel-unpack-buffer [ glTexImage3D ] with-gpu-data-ptr ;
+
+GENERIC# update-texture 4 ( tdt level loc dim data -- )
+
+M:: texture-1d-data-target update-texture ( tdt level loc dim data -- )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level
+ loc dim texture data texture-data-gl-args
+ pixel-unpack-buffer [ glTexSubImage1D ] with-gpu-data-ptr ;
+
+M:: texture-2d-data-target update-texture ( tdt level loc dim data -- )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level
+ loc dim [ first2 ] bi@
+ texture data texture-data-gl-args
+ pixel-unpack-buffer [ glTexSubImage2D ] with-gpu-data-ptr ;
+
+M:: texture-3d-data-target update-texture ( tdt level loc dim data -- )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level
+ loc dim [ first3 ] bi@
+ texture data texture-data-gl-args
+ pixel-unpack-buffer [ glTexSubImage3D ] with-gpu-data-ptr ;
+
+: image>texture-data ( image -- dim texture-data )
+ { [ dim>> ] [ bitmap>> ] [ component-order>> ] [ component-type>> ] } cleave
+ <texture-data> ; inline
+
+GENERIC# texture-dim 1 ( tdt level -- dim )
+
+M:: texture-1d-data-target texture-dim ( tdt level -- dim )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level GL_TEXTURE_WIDTH get-texture-int ;
+
+M:: texture-2d-data-target texture-dim ( tdt level -- dim )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level
+ [ GL_TEXTURE_WIDTH get-texture-int ] [ GL_TEXTURE_HEIGHT get-texture-int ] 2bi
+ 2array ;
+
+M:: texture-3d-data-target texture-dim ( tdt level -- dim )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level
+ [ GL_TEXTURE_WIDTH get-texture-int ]
+ [ GL_TEXTURE_HEIGHT get-texture-int ]
+ [ GL_TEXTURE_DEPTH get-texture-int ] 2tri
+ 3array ;
+
+: texture-data-size ( tdt level -- size )
+ [ texture-dim ?product ] [ drop texture-object bytes-per-pixel ] 2bi * ;
+
+:: read-texture-to ( tdt level gpu-data-ptr -- )
+ tdt bind-tdt :> texture
+ tdt texture-data-gl-target level
+ texture [ component-order>> ] [ component-type>> ] bi image-data-format
+ gpu-data-ptr pixel-pack-buffer [ glGetTexImage ] with-gpu-data-ptr ;
+
+: read-texture ( tdt level -- byte-array )
+ 2dup texture-data-size <byte-array>
+ [ read-texture-to ] keep ;
+
+: allocate-texture-image ( tdt level image -- )
+ image>texture-data allocate-texture ;
+
+: update-texture-image ( tdt level loc image -- )
+ image>texture-data update-texture ;
+
+: read-texture-image ( tdt level -- image )
+ [ texture-dim ]
+ [ drop texture-object [ component-order>> ] [ component-type>> ] bi f ]
+ [ read-texture ] 2tri
+ image boa ;
+
+<PRIVATE
+: bind-texture ( texture -- gl-target )
+ [ texture-gl-target dup ] [ handle>> ] bi glBindTexture ;
+PRIVATE>
+
+: generate-mipmaps ( texture -- )
+ bind-texture glGenerateMipmap ;
+
+: set-texture-parameters ( texture parameters -- )
+ [ bind-texture ] dip {
+ [ wrap>> set-texture-gl-wrap ]
+ [
+ [ GL_TEXTURE_MIN_FILTER ] dip
+ [ min-filter>> ] [ min-mipmap-filter>> ] bi gl-min-filter glTexParameteri
+ ] [
+ [ GL_TEXTURE_MAG_FILTER ] dip
+ mag-filter>> gl-mag-filter glTexParameteri
+ ]
+ [ [ GL_TEXTURE_MIN_LOD ] dip min-lod>> glTexParameteri ]
+ [ [ GL_TEXTURE_MAX_LOD ] dip max-lod>> glTexParameteri ]
+ [ [ GL_TEXTURE_LOD_BIAS ] dip lod-bias>> glTexParameteri ]
+ [ [ GL_TEXTURE_BASE_LEVEL ] dip base-level>> glTexParameteri ]
+ [ [ GL_TEXTURE_MAX_LEVEL ] dip max-level>> glTexParameteri ]
+ } 2cleave ;
+
+<PRIVATE
+
+: <texture> ( component-order component-type parameters class -- texture )
+ '[ [ gen-texture ] 2dip _ boa dup window-resource ] dip
+ [ T{ texture-parameters } clone ] unless* set-texture-parameters ; inline
+
+PRIVATE>
+
+: <texture-1d> ( component-order component-type parameters -- texture )
+ texture-1d <texture> ;
+: <texture-2d> ( component-order component-type parameters -- texture )
+ texture-2d <texture> ;
+: <texture-3d> ( component-order component-type parameters -- texture )
+ texture-3d <texture> ;
+: <texture-cube-map> ( component-order component-type parameters -- texture )
+ texture-cube-map <texture> ;
+: <texture-rectangle> ( component-order component-type parameters -- texture )
+ texture-rectangle <texture> ;
+: <texture-1d-array> ( component-order component-type parameters -- texture )
+ texture-1d-array <texture> ;
+: <texture-2d-array> ( component-order component-type parameters -- texture )
+ texture-2d-array <texture> ;
+
--- /dev/null
+Miscellaneous functions useful for GPU library apps
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: gpu.buffers gpu.render gpu.textures images kernel
+specialized-arrays.float ;
+IN: gpu.util
+
+CONSTANT: environment-cube-map-mv-matrices
+ H{
+ { +X {
+ { 0.0 0.0 -1.0 0.0 }
+ { 0.0 -1.0 0.0 0.0 }
+ { -1.0 0.0 0.0 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } }
+ { +Y {
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 0.0 1.0 0.0 }
+ { 0.0 -1.0 0.0 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } }
+ { +Z {
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 -1.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } }
+ { -X {
+ { 0.0 0.0 1.0 0.0 }
+ { 0.0 -1.0 0.0 0.0 }
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } }
+ { -Y {
+ { 1.0 0.0 0.0 0.0 }
+ { 0.0 0.0 -1.0 0.0 }
+ { 0.0 1.0 0.0 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } }
+ { -Z {
+ { -1.0 0.0 0.0 0.0 }
+ { 0.0 -1.0 0.0 0.0 }
+ { 0.0 0.0 1.0 0.0 }
+ { 0.0 0.0 0.0 1.0 }
+ } }
+ }
+
+VERTEX-FORMAT: window-vertex
+ { "vertex" float-components 2 f } ;
+
+CONSTANT: window-vertexes
+ float-array{
+ -1.0 -1.0
+ -1.0 1.0
+ 1.0 -1.0
+ 1.0 1.0
+ }
+
+: <window-vertex-buffer> ( -- buffer )
+ window-vertexes
+ static-upload draw-usage vertex-buffer
+ byte-array>buffer ;
+
+: <window-vertex-array> ( program-instance -- vertex-array )
+ [ <window-vertex-buffer> ] dip window-vertex buffer>vertex-array ;
--- /dev/null
+Scaffolding for demo scenes that can be explored using FPS-style controls
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays combinators.smart game-input
+game-input.scancodes game-loop game-worlds
+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 ;
+IN: gpu.util.wasd
+
+UNIFORM-TUPLE: mvp-uniforms
+ { "mv_matrix" float-uniform { 4 4 } }
+ { "p_matrix" float-uniform { 4 4 } } ;
+
+CONSTANT: -pi/2 $[ pi -2.0 / ]
+CONSTANT: pi/2 $[ pi 2.0 / ]
+
+TUPLE: wasd-world < game-world location yaw pitch p-matrix ;
+
+GENERIC: wasd-near-plane ( world -- near-plane )
+M: wasd-world wasd-near-plane drop 0.25 ;
+
+GENERIC: wasd-far-plane ( world -- far-plane )
+M: wasd-world wasd-far-plane drop 1024.0 ;
+
+GENERIC: wasd-movement-speed ( world -- speed )
+M: wasd-world wasd-movement-speed drop 1/16. ;
+
+GENERIC: wasd-mouse-scale ( world -- scale )
+M: wasd-world wasd-mouse-scale drop 1/600. ;
+
+GENERIC: wasd-pitch-range ( world -- min max )
+M: wasd-world wasd-pitch-range drop -pi/2 pi/2 ;
+
+GENERIC: wasd-fly-vertically? ( world -- ? )
+M: wasd-world wasd-fly-vertically? drop t ;
+
+: wasd-mv-matrix ( world -- matrix )
+ [ { 1.0 0.0 0.0 } swap pitch>> rotation-matrix4 ]
+ [ { 0.0 1.0 0.0 } swap yaw>> rotation-matrix4 ]
+ [ location>> vneg translation-matrix4 ] tri m. m. ;
+
+: wasd-mv-inv-matrix ( world -- matrix )
+ [ location>> translation-matrix4 ]
+ [ { 0.0 -1.0 0.0 } swap yaw>> rotation-matrix4 ]
+ [ { -1.0 0.0 0.0 } swap pitch>> rotation-matrix4 ] tri m. m. ;
+
+: wasd-p-matrix ( world -- matrix )
+ p-matrix>> ;
+
+CONSTANT: fov 0.7
+
+:: generate-p-matrix ( world -- matrix )
+ world wasd-near-plane :> near-plane
+ world wasd-far-plane :> far-plane
+
+ world dim>> dup first2 min >float v/n fov v*n near-plane v*n
+ near-plane far-plane frustum-matrix4 ;
+
+: set-wasd-view ( world location yaw pitch -- world )
+ [ >>location ] [ >>yaw ] [ >>pitch ] tri* ;
+
+:: eye-rotate ( yaw pitch v -- v' )
+ yaw neg :> y
+ pitch neg :> p
+ y cos :> cosy
+ y sin :> siny
+ p cos :> cosp
+ p sin :> sinp
+
+ cosy 0.0 siny neg 3array
+ siny sinp * cosp cosy sinp * 3array
+ siny cosp * sinp neg cosy cosp * 3array 3array
+ v swap v.m ;
+
+: ?pitch ( world -- pitch )
+ dup wasd-fly-vertically? [ pitch>> ] [ drop 0.0 ] if ;
+
+: forward-vector ( world -- v )
+ [ yaw>> ] [ ?pitch ] [ wasd-movement-speed ] tri
+ { 0.0 0.0 -1.0 } n*v eye-rotate ;
+: rightward-vector ( world -- v )
+ [ yaw>> ] [ ?pitch ] [ wasd-movement-speed ] tri
+ { 1.0 0.0 0.0 } n*v eye-rotate ;
+
+: walk-forward ( world -- )
+ dup forward-vector [ v+ ] curry change-location drop ;
+: walk-backward ( world -- )
+ dup forward-vector [ v- ] curry change-location drop ;
+: walk-leftward ( world -- )
+ dup rightward-vector [ v- ] curry change-location drop ;
+: walk-rightward ( world -- )
+ dup rightward-vector [ v+ ] curry change-location drop ;
+: walk-upward ( world -- )
+ dup wasd-movement-speed { 0.0 1.0 0.0 } n*v [ v+ ] curry change-location drop ;
+: walk-downward ( world -- )
+ dup wasd-movement-speed { 0.0 1.0 0.0 } n*v [ v- ] curry change-location drop ;
+
+: clamp-pitch ( world -- world )
+ dup [ wasd-pitch-range clamp ] curry change-pitch ;
+
+: rotate-with-mouse ( world mouse -- )
+ [ [ dup wasd-mouse-scale ] [ dx>> ] bi* * [ + ] curry change-yaw ]
+ [ [ dup wasd-mouse-scale ] [ dy>> ] bi* * [ + ] curry change-pitch clamp-pitch ] bi
+ drop ;
+
+:: wasd-keyboard-input ( world -- )
+ read-keyboard keys>> :> keys
+ key-w keys nth key-, keys nth or [ world walk-forward ] when
+ key-s keys nth key-o keys nth or [ world walk-backward ] when
+ key-a keys nth [ world walk-leftward ] when
+ key-d keys nth key-e keys nth or [ world walk-rightward ] when
+ key-space keys nth [ world walk-upward ] when
+ key-c keys nth key-j keys nth or [ world walk-downward ] when
+ key-escape keys nth [ world close-window ] when ;
+
+: wasd-mouse-input ( world -- )
+ read-mouse rotate-with-mouse ;
+
+M: wasd-world tick*
+ dup focused?>> [
+ [ wasd-keyboard-input ] [ wasd-mouse-input ] bi
+ reset-mouse
+ ] [ drop ] if ;
+
+M: wasd-world resize-world
+ [ <viewport-state> set-gpu-state* ]
+ [ dup generate-p-matrix >>p-matrix drop ] bi ;
+
[ -1.5 ] [ HEX: be00 bits>half ] unit-test
[ 1/0. ] [ HEX: 7c00 bits>half ] unit-test
[ -1/0. ] [ HEX: fc00 bits>half ] unit-test
+[ 3.0 ] [ HEX: 4200 bits>half ] unit-test
[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
C-STRUCT: halves
! Copyright (C) 2009 Doug Coleman.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel sequences assocs ;\r
+USING: kernel sequences assocs fry ;\r
IN: histogram\r
\r
<PRIVATE\r
\r
: histogram ( seq -- hashtable )\r
[ inc-at ] sequence>hashtable ;\r
+\r
+: collect-values ( seq quot: ( obj hashtable -- ) -- hash )\r
+ '[ [ dup @ ] dip push-at ] sequence>hashtable ; inline\r
[
"h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
"ol" "li" "form" "a" "p" "html" "head" "body" "title"
- "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
+ "b" "i" "ul" "table" "thead" "tfoot" "tbody" "tr" "td" "th" "pre" "textarea"
"script" "div" "span" "select" "option" "style" "input"
"strong"
] [ define-closed-html-word ] each
--- /dev/null
+Matthew Willis
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.libraries alien.syntax system sequences combinators kernel ;
+
+IN: llvm.core
+
+<<
+
+: add-llvm-library ( name -- )
+ dup
+ {
+ { [ os macosx? ] [ "/usr/local/lib/lib" ".dylib" surround ] }
+ { [ os windows? ] [ ".dll" append ] }
+ { [ os unix? ] [ "lib" ".so" surround ] }
+ } cond "cdecl" add-library ;
+
+"LLVMSystem" add-llvm-library
+"LLVMSupport" add-llvm-library
+"LLVMCore" add-llvm-library
+"LLVMBitReader" add-llvm-library
+
+>>
+
+! llvm-c/Core.h
+
+LIBRARY: LLVMCore
+
+TYPEDEF: uint unsigned
+TYPEDEF: unsigned enum
+
+CONSTANT: LLVMZExtAttribute BIN: 1
+CONSTANT: LLVMSExtAttribute BIN: 10
+CONSTANT: LLVMNoReturnAttribute BIN: 100
+CONSTANT: LLVMInRegAttribute BIN: 1000
+CONSTANT: LLVMStructRetAttribute BIN: 10000
+CONSTANT: LLVMNoUnwindAttribute BIN: 100000
+CONSTANT: LLVMNoAliasAttribute BIN: 1000000
+CONSTANT: LLVMByValAttribute BIN: 10000000
+CONSTANT: LLVMNestAttribute BIN: 100000000
+CONSTANT: LLVMReadNoneAttribute BIN: 1000000000
+CONSTANT: LLVMReadOnlyAttribute BIN: 10000000000
+TYPEDEF: enum LLVMAttribute;
+
+C-ENUM:
+ LLVMVoidTypeKind
+ LLVMFloatTypeKind
+ LLVMDoubleTypeKind
+ LLVMX86_FP80TypeKind
+ LLVMFP128TypeKind
+ LLVMPPC_FP128TypeKind
+ LLVMLabelTypeKind
+ LLVMMetadataTypeKind
+ LLVMIntegerTypeKind
+ LLVMFunctionTypeKind
+ LLVMStructTypeKind
+ LLVMArrayTypeKind
+ LLVMPointerTypeKind
+ LLVMOpaqueTypeKind
+ LLVMVectorTypeKind ;
+TYPEDEF: enum LLVMTypeKind
+
+C-ENUM:
+ LLVMExternalLinkage
+ LLVMLinkOnceLinkage
+ LLVMWeakLinkage
+ LLVMAppendingLinkage
+ LLVMInternalLinkage
+ LLVMDLLImportLinkage
+ LLVMDLLExportLinkage
+ LLVMExternalWeakLinkage
+ LLVMGhostLinkage ;
+TYPEDEF: enum LLVMLinkage
+
+C-ENUM:
+ LLVMDefaultVisibility
+ LLVMHiddenVisibility
+ LLVMProtectedVisibility ;
+TYPEDEF: enum LLVMVisibility
+
+CONSTANT: LLVMCCallConv 0
+CONSTANT: LLVMFastCallConv 8
+CONSTANT: LLVMColdCallConv 9
+CONSTANT: LLVMX86StdcallCallConv 64
+CONSTANT: LLVMX86FastcallCallConv 65
+TYPEDEF: enum LLVMCallConv
+
+CONSTANT: LLVMIntEQ 32
+CONSTANT: LLVMIntNE 33
+CONSTANT: LLVMIntUGT 34
+CONSTANT: LLVMIntUGE 35
+CONSTANT: LLVMIntULT 36
+CONSTANT: LLVMIntULE 37
+CONSTANT: LLVMIntSGT 38
+CONSTANT: LLVMIntSGE 39
+CONSTANT: LLVMIntSLT 40
+CONSTANT: LLVMIntSLE 41
+TYPEDEF: enum LLVMIntPredicate
+
+C-ENUM:
+ LLVMRealPredicateFalse
+ LLVMRealOEQ
+ LLVMRealOGT
+ LLVMRealOGE
+ LLVMRealOLT
+ LLVMRealOLE
+ LLVMRealONE
+ LLVMRealORD
+ LLVMRealUNO
+ LLVMRealUEQ
+ LLVMRealUGT
+ LLVMRealUGE
+ LLVMRealULT
+ LLVMRealULE
+ LLVMRealUNE
+ LLVMRealPredicateTrue ;
+TYPEDEF: enum LLVMRealPredicate
+
+! Opaque Types
+
+TYPEDEF: void* LLVMModuleRef
+
+TYPEDEF: void* LLVMPassManagerRef
+
+TYPEDEF: void* LLVMModuleProviderRef
+
+TYPEDEF: void* LLVMTypeRef
+
+TYPEDEF: void* LLVMTypeHandleRef
+
+TYPEDEF: void* LLVMValueRef
+
+TYPEDEF: void* LLVMBasicBlockRef
+
+TYPEDEF: void* LLVMBuilderRef
+
+TYPEDEF: void* LLVMMemoryBufferRef
+
+! Functions
+
+FUNCTION: void LLVMDisposeMessage ( char* Message ) ;
+
+FUNCTION: LLVMModuleRef LLVMModuleCreateWithName ( char* ModuleID ) ;
+
+FUNCTION: int LLVMAddTypeName ( LLVMModuleRef M, char* Name, LLVMTypeRef Ty ) ;
+
+FUNCTION: void LLVMDisposeModule ( LLVMModuleRef M ) ;
+
+FUNCTION: void LLVMDumpModule ( LLVMModuleRef M ) ;
+
+FUNCTION: LLVMModuleProviderRef
+LLVMCreateModuleProviderForExistingModule ( LLVMModuleRef M ) ;
+
+FUNCTION: void LLVMDisposeModuleProvider ( LLVMModuleProviderRef MP ) ;
+
+! Types
+
+! LLVM types conform to the following hierarchy:
+!
+! types:
+! integer type
+! real type
+! function type
+! sequence types:
+! array type
+! pointer type
+! vector type
+! void type
+! label type
+! opaque type
+
+! See llvm::LLVMTypeKind::getTypeID.
+FUNCTION: LLVMTypeKind LLVMGetTypeKind ( LLVMTypeRef Ty ) ;
+
+! Operations on integer types
+FUNCTION: LLVMTypeRef LLVMInt1Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMInt8Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMInt16Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMInt32Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMInt64Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMIntType ( unsigned NumBits ) ;
+FUNCTION: unsigned LLVMGetIntTypeWidth ( LLVMTypeRef IntegerTy ) ;
+
+! Operations on real types
+FUNCTION: LLVMTypeRef LLVMFloatType ( ) ;
+FUNCTION: LLVMTypeRef LLVMDoubleType ( ) ;
+FUNCTION: LLVMTypeRef LLVMX86FP80Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMFP128Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMPPCFP128Type ( ) ;
+
+! Operations on function types
+FUNCTION: LLVMTypeRef
+LLVMFunctionType ( LLVMTypeRef ReturnType, LLVMTypeRef* ParamTypes, unsigned ParamCount, int IsVarArg ) ;
+FUNCTION: int LLVMIsFunctionVarArg ( LLVMTypeRef FunctionTy ) ;
+FUNCTION: LLVMTypeRef LLVMGetReturnType ( LLVMTypeRef FunctionTy ) ;
+FUNCTION: unsigned LLVMCountParamTypes ( LLVMTypeRef FunctionTy ) ;
+FUNCTION: void LLVMGetParamTypes ( LLVMTypeRef FunctionTy, LLVMTypeRef* Dest ) ;
+
+! Operations on struct types
+FUNCTION: LLVMTypeRef
+LLVMStructType ( LLVMTypeRef* ElementTypes, unsigned ElementCount, int Packed ) ;
+FUNCTION: unsigned LLVMCountStructElementTypes ( LLVMTypeRef StructTy ) ;
+FUNCTION: void LLVMGetStructElementTypes ( LLVMTypeRef StructTy, LLVMTypeRef* Dest ) ;
+FUNCTION: int LLVMIsPackedStruct ( LLVMTypeRef StructTy ) ;
+
+! Operations on array, pointer, and vector types (sequence types)
+FUNCTION: LLVMTypeRef LLVMArrayType ( LLVMTypeRef ElementType, unsigned ElementCount ) ;
+FUNCTION: LLVMTypeRef LLVMPointerType ( LLVMTypeRef ElementType, unsigned AddressSpace ) ;
+FUNCTION: LLVMTypeRef LLVMVectorType ( LLVMTypeRef ElementType, unsigned ElementCount ) ;
+
+FUNCTION: LLVMTypeRef LLVMGetElementType ( LLVMTypeRef Ty ) ;
+FUNCTION: unsigned LLVMGetArrayLength ( LLVMTypeRef ArrayTy ) ;
+FUNCTION: unsigned LLVMGetPointerAddressSpace ( LLVMTypeRef PointerTy ) ;
+FUNCTION: unsigned LLVMGetVectorSize ( LLVMTypeRef VectorTy ) ;
+
+! Operations on other types
+FUNCTION: LLVMTypeRef LLVMVoidType ( ) ;
+FUNCTION: LLVMTypeRef LLVMLabelType ( ) ;
+FUNCTION: LLVMTypeRef LLVMOpaqueType ( ) ;
+
+! Operations on type handles
+FUNCTION: LLVMTypeHandleRef LLVMCreateTypeHandle ( LLVMTypeRef PotentiallyAbstractTy ) ;
+FUNCTION: void LLVMRefineType ( LLVMTypeRef AbstractTy, LLVMTypeRef ConcreteTy ) ;
+FUNCTION: LLVMTypeRef LLVMResolveTypeHandle ( LLVMTypeHandleRef TypeHandle ) ;
+FUNCTION: void LLVMDisposeTypeHandle ( LLVMTypeHandleRef TypeHandle ) ;
+
+! Types end
+
+FUNCTION: unsigned LLVMCountParams ( LLVMValueRef Fn ) ;
+
+FUNCTION: void LLVMGetParams ( LLVMValueRef Fn, LLVMValueRef* Params ) ;
+
+FUNCTION: LLVMValueRef
+LLVMAddFunction ( LLVMModuleRef M, char* Name, LLVMTypeRef FunctionTy ) ;
+
+FUNCTION: LLVMValueRef LLVMGetFirstFunction ( LLVMModuleRef M ) ;
+
+FUNCTION: LLVMValueRef LLVMGetNextFunction ( LLVMValueRef Fn ) ;
+
+FUNCTION: unsigned LLVMGetFunctionCallConv ( LLVMValueRef Fn ) ;
+
+FUNCTION: void LLVMSetFunctionCallConv ( LLVMValueRef Fn, unsigned CC ) ;
+
+FUNCTION: LLVMBasicBlockRef
+LLVMAppendBasicBlock ( LLVMValueRef Fn, char* Name ) ;
+
+FUNCTION: LLVMValueRef LLVMGetBasicBlockParent ( LLVMBasicBlockRef BB ) ;
+
+! Values
+
+FUNCTION: LLVMTypeRef LLVMTypeOf ( LLVMValueRef Val ) ;
+FUNCTION: char* LLVMGetValueName ( LLVMValueRef Val ) ;
+FUNCTION: void LLVMSetValueName ( LLVMValueRef Val, char* Name ) ;
+FUNCTION: void LLVMDumpValue ( LLVMValueRef Val ) ;
+
+! Instruction Builders
+
+FUNCTION: LLVMBuilderRef LLVMCreateBuilder ( ) ;
+FUNCTION: void LLVMPositionBuilder
+( LLVMBuilderRef Builder, LLVMBasicBlockRef Block, LLVMValueRef Instr ) ;
+FUNCTION: void LLVMPositionBuilderBefore
+( LLVMBuilderRef Builder, LLVMValueRef Instr ) ;
+FUNCTION: void LLVMPositionBuilderAtEnd
+( LLVMBuilderRef Builder, LLVMBasicBlockRef Block ) ;
+FUNCTION: LLVMBasicBlockRef LLVMGetInsertBlock
+( LLVMBuilderRef Builder ) ;
+FUNCTION: void LLVMClearInsertionPosition
+( LLVMBuilderRef Builder ) ;
+FUNCTION: void LLVMInsertIntoBuilder
+( LLVMBuilderRef Builder, LLVMValueRef Instr ) ;
+FUNCTION: void LLVMDisposeBuilder
+( LLVMBuilderRef Builder ) ;
+
+! IB Terminators
+
+FUNCTION: LLVMValueRef LLVMBuildRetVoid
+( LLVMBuilderRef Builder ) ;
+FUNCTION: LLVMValueRef LLVMBuildRet
+( LLVMBuilderRef Builder, LLVMValueRef V ) ;
+FUNCTION: LLVMValueRef LLVMBuildBr
+( LLVMBuilderRef Builder, LLVMBasicBlockRef Dest ) ;
+FUNCTION: LLVMValueRef LLVMBuildCondBr
+( LLVMBuilderRef Builder, LLVMValueRef If, LLVMBasicBlockRef Then, LLVMBasicBlockRef Else ) ;
+FUNCTION: LLVMValueRef LLVMBuildSwitch
+( LLVMBuilderRef Builder, LLVMValueRef V, LLVMBasicBlockRef Else, unsigned NumCases ) ;
+FUNCTION: LLVMValueRef LLVMBuildInvoke
+( LLVMBuilderRef Builder, LLVMValueRef Fn, LLVMValueRef* Args, unsigned NumArgs,
+ LLVMBasicBlockRef Then, LLVMBasicBlockRef Catch, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildUnwind
+( LLVMBuilderRef Builder ) ;
+FUNCTION: LLVMValueRef LLVMBuildUnreachable
+( LLVMBuilderRef Builder ) ;
+
+! IB Add Case to Switch
+
+FUNCTION: void LLVMAddCase
+( LLVMValueRef Switch, LLVMValueRef OnVal, LLVMBasicBlockRef Dest ) ;
+
+! IB Arithmetic
+
+FUNCTION: LLVMValueRef LLVMBuildAdd
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildSub
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildMul
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildUDiv
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildSDiv
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildFDiv
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildURem
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildSRem
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildFRem
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildShl
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildLShr
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildAShr
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildAnd
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildOr
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildXor
+( LLVMBuilderRef Builder, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildNeg
+( LLVMBuilderRef Builder, LLVMValueRef V, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildNot
+( LLVMBuilderRef Builder, LLVMValueRef V, char* Name ) ;
+
+! IB Memory
+
+FUNCTION: LLVMValueRef LLVMBuildMalloc
+( LLVMBuilderRef Builder, LLVMTypeRef Ty, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildArrayMalloc
+( LLVMBuilderRef Builder, LLVMTypeRef Ty, LLVMValueRef Val, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildAlloca
+( LLVMBuilderRef Builder, LLVMTypeRef Ty, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildArrayAlloca
+( LLVMBuilderRef Builder, LLVMTypeRef Ty, LLVMValueRef Val, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildFree
+( LLVMBuilderRef Builder, LLVMValueRef PointerVal ) ;
+FUNCTION: LLVMValueRef LLVMBuildLoad
+( LLVMBuilderRef Builder, LLVMValueRef PointerVal, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildStore
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMValueRef Ptr ) ;
+FUNCTION: LLVMValueRef LLVMBuildGEP
+( LLVMBuilderRef B, LLVMValueRef Pointer, LLVMValueRef* Indices,
+ unsigned NumIndices, char* Name ) ;
+
+! IB Casts
+
+FUNCTION: LLVMValueRef LLVMBuildTrunc
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildZExt
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildSExt
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildFPToUI
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildFPToSI
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildUIToFP
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildSIToFP
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildFPTrunc
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildFPExt
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildPtrToInt
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildIntToPtr
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildBitCast
+( LLVMBuilderRef Builder, LLVMValueRef Val, LLVMTypeRef DestTy, char* Name ) ;
+
+! IB Comparisons
+
+FUNCTION: LLVMValueRef LLVMBuildICmp
+( LLVMBuilderRef Builder, LLVMIntPredicate Op, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildFCmp
+( LLVMBuilderRef Builder, LLVMRealPredicate Op, LLVMValueRef LHS, LLVMValueRef RHS, char* Name ) ;
+
+! IB Misc Instructions
+
+FUNCTION: LLVMValueRef LLVMBuildPhi
+( LLVMBuilderRef Builder, LLVMTypeRef Ty, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildCall
+( LLVMBuilderRef Builder, LLVMValueRef Fn, LLVMValueRef* Args, unsigned NumArgs, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildSelect
+( LLVMBuilderRef Builder, LLVMValueRef If, LLVMValueRef Then, LLVMValueRef Else, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildVAArg
+( LLVMBuilderRef Builder, LLVMValueRef List, LLVMTypeRef Ty, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildExtractElement
+( LLVMBuilderRef Builder, LLVMValueRef VecVal, LLVMValueRef Index, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildInsertElement
+( LLVMBuilderRef Builder, LLVMValueRef VecVal, LLVMValueRef EltVal, LLVMValueRef Index, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildShuffleVector
+( LLVMBuilderRef Builder, LLVMValueRef V1, LLVMValueRef V2, LLVMValueRef Mask, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildExtractValue
+( LLVMBuilderRef Builder, LLVMValueRef AggVal, unsigned Index, char* Name ) ;
+FUNCTION: LLVMValueRef LLVMBuildInsertValue
+( LLVMBuilderRef Builder, LLVMValueRef AggVal, LLVMValueRef EltVal, unsigned Index, char* Name ) ;
+
+! Memory Buffers/Bit Reader
+
+FUNCTION: int LLVMCreateMemoryBufferWithContentsOfFile
+( char* Path, LLVMMemoryBufferRef* OutMemBuf, char** OutMessage ) ;
+
+FUNCTION: void LLVMDisposeMemoryBuffer ( LLVMMemoryBufferRef MemBuf ) ;
+
+LIBRARY: LLVMBitReader
+
+FUNCTION: int LLVMParseBitcode
+( LLVMMemoryBufferRef MemBuf, LLVMModuleRef* OutModule, char** OutMessage ) ;
+
+FUNCTION: int LLVMGetBitcodeModuleProvider
+( LLVMMemoryBufferRef MemBuf, LLVMModuleProviderRef* OutMP, char** OutMessage ) ;
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.libraries alien.syntax llvm.core ;
+IN: llvm.engine
+
+<<
+
+"LLVMExecutionEngine" add-llvm-library
+"LLVMTarget" add-llvm-library
+"LLVMAnalysis" add-llvm-library
+"LLVMipa" add-llvm-library
+"LLVMTransformUtils" add-llvm-library
+"LLVMScalarOpts" add-llvm-library
+"LLVMCodeGen" add-llvm-library
+"LLVMAsmPrinter" add-llvm-library
+"LLVMSelectionDAG" add-llvm-library
+"LLVMX86CodeGen" add-llvm-library
+"LLVMJIT" add-llvm-library
+"LLVMInterpreter" add-llvm-library
+
+>>
+
+! llvm-c/ExecutionEngine.h
+
+LIBRARY: LLVMExecutionEngine
+
+TYPEDEF: void* LLVMGenericValueRef
+TYPEDEF: void* LLVMExecutionEngineRef
+
+FUNCTION: LLVMGenericValueRef LLVMCreateGenericValueOfInt
+( LLVMTypeRef Ty, ulonglong N, int IsSigned ) ;
+
+FUNCTION: ulonglong LLVMGenericValueToInt
+( LLVMGenericValueRef GenVal, int IsSigned ) ;
+
+FUNCTION: int LLVMCreateExecutionEngine
+( LLVMExecutionEngineRef *OutEE, LLVMModuleProviderRef MP, char** OutError ) ;
+
+FUNCTION: int LLVMCreateJITCompiler
+( LLVMExecutionEngineRef* OutJIT, LLVMModuleProviderRef MP, unsigned OptLevel, char** OutError ) ;
+
+FUNCTION: void LLVMDisposeExecutionEngine ( LLVMExecutionEngineRef EE ) ;
+
+FUNCTION: void LLVMFreeMachineCodeForFunction ( LLVMExecutionEngineRef EE, LLVMValueRef F ) ;
+
+FUNCTION: void LLVMAddModuleProvider ( LLVMExecutionEngineRef EE, LLVMModuleProviderRef MP ) ;
+
+FUNCTION: int LLVMRemoveModuleProvider
+( LLVMExecutionEngineRef EE, LLVMModuleProviderRef MP, LLVMModuleRef* OutMod, char** OutError ) ;
+
+FUNCTION: int LLVMFindFunction
+( LLVMExecutionEngineRef EE, char* Name, LLVMValueRef* OutFn ) ;
+
+FUNCTION: void* LLVMGetPointerToGlobal ( LLVMExecutionEngineRef EE, LLVMValueRef Global ) ;
+
+FUNCTION: LLVMGenericValueRef LLVMRunFunction
+( LLVMExecutionEngineRef EE, LLVMValueRef F, unsigned NumArgs, LLVMGenericValueRef* Args ) ;
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.llvm io.pathnames llvm.invoker llvm.reader tools.test ;
+
+[ 3 ] [
+ << "resource:extra/llvm/reader/add.bc" install-bc >> 1 2 add
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! 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
+vocabs words ;
+
+IN: llvm.invoker
+
+! get function name, ret type, param types and names
+
+! load module
+! iterate through functions in a module
+
+TUPLE: function name alien return params ;
+
+: params ( llvm-function -- param-list )
+ dup LLVMCountParams <void*-array>
+ [ LLVMGetParams ] keep >array
+ [ [ LLVMGetValueName ] [ LLVMTypeOf tref> ] bi 2array ] map ;
+
+: <function> ( LLVMValueRef -- function )
+ function new
+ over LLVMGetValueName >>name
+ over LLVMTypeOf tref> type>> return>> >>return
+ swap params >>params ;
+
+: (functions) ( llvm-function -- )
+ [ dup , LLVMGetNextFunction (functions) ] when* ;
+
+: functions ( llvm-module -- functions )
+ LLVMGetFirstFunction [ (functions) ] { } make [ <function> ] map ;
+
+: function-effect ( function -- effect )
+ [ params>> [ first ] map ] [ return>> void? 0 1 ? ] bi <effect> ;
+
+: install-function ( function -- )
+ dup name>> "alien.llvm" create-vocab drop
+ "alien.llvm" create swap
+ [
+ dup name>> function-pointer ,
+ dup return>> c-type ,
+ dup params>> [ second c-type ] map ,
+ "cdecl" , \ alien-indirect ,
+ ] [ ] make swap function-effect [ define-declared ] with-compilation-unit ;
+
+: install-module ( name -- )
+ thejit get mps>> at [
+ module>> functions [ install-function ] each
+ ] [ "no such module" throw ] if* ;
+
+: install-bc ( path -- )
+ [ normalize-path ] [ file-name ] bi
+ [ load-into-jit ] keep install-module ;
+
+<< "alien.llvm" create-vocab drop >>
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: destructors llvm.jit llvm.wrappers tools.test ;
+
+[ ] [ "test" <module> "test" add-module "test" remove-module ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.syntax assocs destructors
+kernel llvm.core llvm.engine llvm.wrappers namespaces ;
+
+IN: llvm.jit
+
+SYMBOL: thejit
+
+TUPLE: jit ee mps ;
+
+: empty-engine ( -- engine )
+ "initial-module" <module> <provider> <engine> ;
+
+: <jit> ( -- jit )
+ jit new empty-engine >>ee H{ } clone >>mps ;
+
+: (remove-functions) ( function -- )
+ thejit get ee>> value>> over LLVMFreeMachineCodeForFunction
+ LLVMGetNextFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ;
+
+: remove-functions ( module -- )
+ ! free machine code for each function in module
+ LLVMGetFirstFunction dup ALIEN: 0 = [ drop ] [ (remove-functions) ] if ;
+
+: remove-provider ( provider -- )
+ thejit get ee>> value>> swap value>> f <void*> f <void*>
+ [ LLVMRemoveModuleProvider drop ] 2keep *void* [ llvm-throw ] when*
+ *void* module new swap >>value
+ [ value>> remove-functions ] with-disposal ;
+
+: remove-module ( name -- )
+ dup thejit get mps>> at [
+ remove-provider
+ thejit get mps>> delete-at
+ ] [ drop ] if* ;
+
+: add-module ( module name -- )
+ [ <provider> ] dip [ remove-module ] keep
+ thejit get ee>> value>> pick
+ [ [ value>> LLVMAddModuleProvider ] [ t >>disposed drop ] bi ] with-disposal
+ thejit get mps>> set-at ;
+
+: function-pointer ( name -- alien )
+ thejit get ee>> value>> dup
+ rot f <void*> [ LLVMFindFunction drop ] keep
+ *void* LLVMGetPointerToGlobal ;
+
+thejit [ <jit> ] initialize
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+define i32 @add(i32 %x, i32 %y) {
+entry:
+ %sum = add i32 %x, %y
+ ret i32 %sum
+}
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.syntax destructors kernel
+llvm.core llvm.engine llvm.jit llvm.wrappers ;
+
+IN: llvm.reader
+
+: buffer>module ( buffer -- module )
+ [
+ value>> f <void*> f <void*>
+ [ LLVMParseBitcode drop ] 2keep
+ *void* [ llvm-throw ] when* *void*
+ module new swap >>value
+ ] with-disposal ;
+
+: load-module ( path -- module )
+ <buffer> buffer>module ;
+
+: load-into-jit ( path name -- )
+ [ load-module ] dip add-module ;
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+bindings
+unportable
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel llvm.types sequences tools.test ;
+
+[ T{ integer f 32 } ] [ " i32 " parse-type ] unit-test
+[ float ] [ " float " parse-type ] unit-test
+[ T{ pointer f f x86_fp80 } ] [ " x86_fp80 * " parse-type ] unit-test
+[ T{ vector f f 4 T{ integer f 32 } } ] [ " < 4 x i32 > " parse-type ] unit-test
+[ T{ struct f f { float double } f } ] [ TYPE: { float , double } ; ] unit-test
+[ T{ array f f 0 float } ] [ TYPE: [ 0 x float ] ; ] unit-test
+
+[ label void metadata ]
+[ [ " label " " void " " metadata " ] [ parse-type ] each ] unit-test
+
+[ T{ function f f float { float float } t } ]
+[ TYPE: float ( float , float , ... ) ; ] unit-test
+
+[ T{ struct f f { float TYPE: i32 (i32)* ; } t } ]
+[ TYPE: < { float, i32 (i32)* } > ; ] unit-test
+
+[ t ] [ TYPE: i32 ; TYPE: i32 ; [ >tref ] bi@ = ] unit-test
+[ t ] [ TYPE: i32 * ; TYPE: i32 * ; [ >tref ] bi@ = ] unit-test
+
+[ TYPE: i32 ; ] [ TYPE: i32 ; >tref tref> ] unit-test
+[ TYPE: float ; ] [ TYPE: float ; >tref tref> ] unit-test
+[ TYPE: double ; ] [ TYPE: double ; >tref tref> ] unit-test
+[ TYPE: x86_fp80 ; ] [ TYPE: x86_fp80 ; >tref tref> ] unit-test
+[ TYPE: fp128 ; ] [ TYPE: fp128 ; >tref tref> ] unit-test
+[ TYPE: ppc_fp128 ; ] [ TYPE: ppc_fp128 ; >tref tref> ] unit-test
+[ TYPE: opaque ; ] [ TYPE: opaque ; >tref tref> ] unit-test
+[ TYPE: label ; ] [ TYPE: label ; >tref tref> ] unit-test
+[ TYPE: void ; ] [ TYPE: void ; >tref tref> ] unit-test
+[ TYPE: i32* ; ] [ TYPE: i32* ; >tref tref> ] unit-test
+[ TYPE: < 2 x i32 > ; ] [ TYPE: < 2 x i32 > ; >tref tref> ] unit-test
+[ TYPE: [ 0 x i32 ] ; ] [ TYPE: [ 0 x i32 ] ; >tref tref> ] unit-test
+[ TYPE: { i32, i32 } ; ] [ TYPE: { i32, i32 } ; >tref tref> ] unit-test
+[ TYPE: < { i32, i32 } > ; ] [ TYPE: < { i32, i32 } > ; >tref tref> ] unit-test
+[ TYPE: i32 ( i32 ) ; ] [ TYPE: i32 ( i32 ) ; >tref tref> ] unit-test
+[ TYPE: \1* ; ] [ TYPE: \1* ; >tref tref> ] unit-test
+[ TYPE: { i32, \2* } ; ] [ TYPE: { i32, \2* } ; >tref tref> ] unit-test
\ No newline at end of file
--- /dev/null
+! 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 ;
+
+IN: llvm.types
+
+! Type resolution strategy:
+! pass 1:
+! create the type with uprefs mapped to opaque types
+! cache typerefs in enclosing types for pass 2
+! if our type is concrete, then we are done
+!
+! pass 2:
+! wrap our abstract type in a type handle
+! create a second type, using the cached enclosing type info
+! resolve the first type to the second
+!
+GENERIC: (>tref) ( type -- LLVMTypeRef )
+GENERIC: ((tref>)) ( LLVMTypeRef type -- type )
+GENERIC: c-type ( type -- str )
+
+! default implementation for simple types
+M: object ((tref>)) nip ;
+: unsupported-type ( -- )
+ "cannot generate c-type: unsupported llvm type" throw ;
+M: object c-type unsupported-type ;
+
+TUPLE: integer size ;
+C: <integer> integer
+
+M: integer (>tref) size>> LLVMIntType ;
+M: integer ((tref>)) swap LLVMGetIntTypeWidth >>size ;
+M: integer c-type size>> {
+ { 64 [ "longlong" ] }
+ { 32 [ "int" ] }
+ { 16 [ "short" ] }
+ { 8 [ "char" ] }
+ [ unsupported-type ]
+} case ;
+
+SINGLETONS: float double x86_fp80 fp128 ppc_fp128 ;
+
+M: float (>tref) drop LLVMFloatType ;
+M: double (>tref) drop LLVMDoubleType ;
+M: double c-type drop "double" ;
+M: x86_fp80 (>tref) drop LLVMX86FP80Type ;
+M: fp128 (>tref) drop LLVMFP128Type ;
+M: ppc_fp128 (>tref) drop LLVMPPCFP128Type ;
+
+SINGLETONS: opaque label void metadata ;
+
+M: opaque (>tref) drop LLVMOpaqueType ;
+M: label (>tref) drop LLVMLabelType ;
+M: void (>tref) drop LLVMVoidType ;
+M: void c-type drop "void" ;
+M: metadata (>tref) drop
+ "metadata types unsupported by llvm c bindings" throw ;
+
+! enclosing types cache their llvm refs during
+! the first pass, used in the second pass to
+! resolve uprefs
+TUPLE: enclosing cached ;
+
+GENERIC: clean ( type -- )
+GENERIC: clean* ( type -- )
+M: object clean drop ;
+M: enclosing clean f >>cached clean* ;
+
+! builds the stack of types that uprefs need to refer to
+SYMBOL: types
+:: push-type ( type quot: ( type -- LLVMTypeRef ) -- LLVMTypeRef )
+ type types get push
+ type quot call( type -- LLVMTypeRef )
+ types get pop over >>cached drop ;
+
+DEFER: <up-ref>
+:: push-ref ( ref quot: ( LLVMTypeRef -- type ) -- type )
+ ref types get index
+ [ types get length swap - <up-ref> ] [
+ ref types get push
+ ref quot call( LLVMTypeRef -- type )
+ types get pop drop
+ ] if* ;
+
+GENERIC: (>tref)* ( type -- LLVMTypeRef )
+M: enclosing (>tref) [ (>tref)* ] push-type ;
+
+DEFER: type-kind
+GENERIC: (tref>)* ( LLVMTypeRef type -- type )
+M: enclosing ((tref>)) [ (tref>)* ] curry push-ref ;
+
+: (tref>) ( LLVMTypeRef -- type ) dup type-kind ((tref>)) ;
+
+TUPLE: pointer < enclosing type ;
+: <pointer> ( t -- o ) pointer new swap >>type ;
+
+M: pointer (>tref)* type>> (>tref) 0 LLVMPointerType ;
+M: pointer clean* type>> clean ;
+M: pointer (tref>)* swap LLVMGetElementType (tref>) >>type ;
+M: pointer c-type type>> 8 <integer> = "char*" "void*" ? ;
+
+TUPLE: vector < enclosing size type ;
+: <vector> ( s t -- o )
+ vector new
+ swap >>type swap >>size ;
+
+M: vector (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMVectorType ;
+M: vector clean* type>> clean ;
+M: vector (tref>)*
+ over LLVMGetElementType (tref>) >>type
+ swap LLVMGetVectorSize >>size ;
+
+TUPLE: struct < enclosing types packed? ;
+: <struct> ( ts p? -- o )
+ struct new
+ swap >>packed? swap >>types ;
+
+M: struct (>tref)*
+ [ types>> [ (>tref) ] map >void*-array ]
+ [ types>> length ]
+ [ packed?>> 1 0 ? ] tri LLVMStructType ;
+M: struct clean* types>> [ clean ] each ;
+M: struct (tref>)*
+ over LLVMIsPackedStruct 0 = not >>packed?
+ swap dup LLVMCountStructElementTypes <void*-array>
+ [ LLVMGetStructElementTypes ] keep >array
+ [ (tref>) ] map >>types ;
+
+TUPLE: array < enclosing size type ;
+: <array> ( s t -- o )
+ array new
+ swap >>type swap >>size ;
+
+M: array (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMArrayType ;
+M: array clean* type>> clean ;
+M: array (tref>)*
+ over LLVMGetElementType (tref>) >>type
+ swap LLVMGetArrayLength >>size ;
+
+SYMBOL: ...
+TUPLE: function < enclosing return params vararg? ;
+: <function> ( ret params var? -- o )
+ function new
+ swap >>vararg? swap >>params swap >>return ;
+
+M: function (>tref)* {
+ [ return>> (>tref) ]
+ [ params>> [ (>tref) ] map >void*-array ]
+ [ params>> length ]
+ [ vararg?>> 1 0 ? ]
+} cleave LLVMFunctionType ;
+M: function clean* [ return>> clean ] [ params>> [ clean ] each ] bi ;
+M: function (tref>)*
+ over LLVMIsFunctionVarArg 0 = not >>vararg?
+ over LLVMGetReturnType (tref>) >>return
+ swap dup LLVMCountParamTypes <void*-array>
+ [ LLVMGetParamTypes ] keep >array
+ [ (tref>) ] map >>params ;
+
+: type-kind ( LLVMTypeRef -- class )
+ LLVMGetTypeKind {
+ { LLVMVoidTypeKind [ void ] }
+ { LLVMFloatTypeKind [ float ] }
+ { LLVMDoubleTypeKind [ double ] }
+ { LLVMX86_FP80TypeKind [ x86_fp80 ] }
+ { LLVMFP128TypeKind [ fp128 ] }
+ { LLVMPPC_FP128TypeKind [ ppc_fp128 ] }
+ { LLVMLabelTypeKind [ label ] }
+ { LLVMIntegerTypeKind [ integer new ] }
+ { LLVMFunctionTypeKind [ function new ] }
+ { LLVMStructTypeKind [ struct new ] }
+ { LLVMArrayTypeKind [ array new ] }
+ { LLVMPointerTypeKind [ pointer new ] }
+ { LLVMOpaqueTypeKind [ opaque ] }
+ { LLVMVectorTypeKind [ vector new ] }
+ } case ;
+
+TUPLE: up-ref height ;
+C: <up-ref> up-ref
+
+M: up-ref (>tref)
+ types get length swap height>> - types get nth
+ cached>> [ LLVMOpaqueType ] unless* ;
+
+: resolve-types ( typeref typeref -- typeref )
+ over LLVMCreateTypeHandle [ LLVMRefineType ] dip
+ [ LLVMResolveTypeHandle ] keep LLVMDisposeTypeHandle ;
+
+: >tref-caching ( type -- LLVMTypeRef )
+ V{ } clone types [ (>tref) ] with-variable ;
+
+: >tref ( type -- LLVMTypeRef )
+ [ >tref-caching ] [ >tref-caching ] [ clean ] tri
+ 2dup = [ drop ] [ resolve-types ] if ;
+
+: tref> ( LLVMTypeRef -- type )
+ V{ } clone types [ (tref>) ] with-variable ;
+
+: t. ( type -- )
+ >tref
+ "type-info" LLVMModuleCreateWithName
+ [ "t" rot LLVMAddTypeName drop ]
+ [ LLVMDumpModule ]
+ [ LLVMDisposeModule ] tri ;
+
+EBNF: parse-type
+
+WhiteSpace = " "*
+
+Zero = "0" => [[ drop 0 ]]
+LeadingDigit = [1-9]
+DecimalDigit = [0-9]
+Number = LeadingDigit:d (DecimalDigit)*:ds => [[ ds d prefix string>number ]]
+WhiteNumberSpace = WhiteSpace Number:n WhiteSpace => [[ n ]]
+WhiteZeroSpace = WhiteSpace (Zero | Number):n WhiteSpace => [[ n ]]
+
+Integer = "i" Number:n => [[ n <integer> ]]
+FloatingPoint = ( "float" | "double" | "x86_fp80" | "fp128" | "ppc_fp128" ) => [[ "llvm.types" vocab lookup ]]
+LabelVoidMetadata = ( "label" | "void" | "metadata" | "opaque" ) => [[ "llvm.types" vocab lookup ]]
+Primitive = LabelVoidMetadata | FloatingPoint
+Pointer = T:t WhiteSpace "*" => [[ t <pointer> ]]
+Vector = "<" WhiteNumberSpace:n "x" Type:t ">" => [[ n t <vector> ]]
+StructureTypesList = "," Type:t => [[ t ]]
+Structure = "{" Type:t (StructureTypesList)*:ts "}" => [[ ts t prefix >array f <struct> ]]
+Array = "[" WhiteZeroSpace:n "x" Type:t "]" => [[ n t <array> ]]
+NoFunctionParams = "(" WhiteSpace ")" => [[ drop { } ]]
+VarArgs = WhiteSpace "..." WhiteSpace => [[ drop ... ]]
+ParamListContinued = "," (Type | VarArgs):t => [[ t ]]
+ParamList = "(" Type:t (ParamListContinued*):ts ")" => [[ ts t prefix ]]
+Function = T:t WhiteSpace ( ParamList | NoFunctionParams ):ts => [[ ... ts member? dup [ ... ts delete ] when t ts >array rot <function> ]]
+PackedStructure = "<" WhiteSpace "{" Type:ty (StructureTypesList)*:ts "}" WhiteSpace ">" => [[ ts ty prefix >array t <struct> ]]
+UpReference = "\\" Number:n => [[ n <up-ref> ]]
+Name = '%' ([a-zA-Z][a-zA-Z0-9]*):id => [[ id flatten >string ]]
+
+T = Pointer | Function | Primitive | Integer | Vector | Structure | PackedStructure | Array | UpReference | Name
+
+Type = WhiteSpace T:t WhiteSpace => [[ t ]]
+
+Program = Type
+
+;EBNF
+
+SYNTAX: TYPE: ";" parse-multiline-string parse-type parsed ;
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: destructors kernel llvm.wrappers sequences tools.test vocabs ;
+
+[ ] [ "test" <module> dispose ] unit-test
+[ ] [ "test" <module> <provider> dispose ] unit-test
+[ ] [ "llvm.jit" vocabs member? [ "test" <module> <provider> <engine> dispose ] unless ] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types alien.strings
+io.encodings.utf8 destructors kernel
+llvm.core llvm.engine ;
+
+IN: llvm.wrappers
+
+: llvm-throw ( char* -- )
+ [ utf8 alien>string ] [ LLVMDisposeMessage ] bi throw ;
+
+: <dispose> ( alien class -- disposable ) new swap >>value ;
+
+TUPLE: module value disposed ;
+M: module dispose* value>> LLVMDisposeModule ;
+
+: <module> ( name -- module )
+ LLVMModuleCreateWithName module <dispose> ;
+
+TUPLE: provider value module disposed ;
+M: provider dispose* value>> LLVMDisposeModuleProvider ;
+
+: (provider) ( module -- provider )
+ [ value>> LLVMCreateModuleProviderForExistingModule provider <dispose> ]
+ [ t >>disposed value>> ] bi
+ >>module ;
+
+: <provider> ( module -- provider )
+ [ (provider) ] with-disposal ;
+
+TUPLE: engine value disposed ;
+M: engine dispose* value>> LLVMDisposeExecutionEngine ;
+
+: (engine) ( provider -- engine )
+ [
+ value>> f <void*> f <void*>
+ [ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep
+ *void* [ llvm-throw ] when* *void*
+ ]
+ [ t >>disposed drop ] bi
+ engine <dispose> ;
+
+: <engine> ( provider -- engine )
+ [ (engine) ] with-disposal ;
+
+: (add-block) ( name -- basic-block )
+ "function" swap LLVMAppendBasicBlock ;
+
+TUPLE: builder value disposed ;
+M: builder dispose* value>> LLVMDisposeBuilder ;
+
+: <builder> ( name -- builder )
+ (add-block) LLVMCreateBuilder [ swap LLVMPositionBuilderAtEnd ] keep
+ builder <dispose> ;
+
+TUPLE: buffer value disposed ;
+M: buffer dispose* value>> LLVMDisposeMemoryBuffer ;
+
+: <buffer> ( path -- module )
+ f <void*> f <void*>
+ [ LLVMCreateMemoryBufferWithContentsOfFile drop ] 2keep
+ *void* [ llvm-throw ] when* *void* buffer <dispose> ;
\ No newline at end of file
[ create-collection ] keep ;
: prepare-index ( collection -- )
- "_x_idx" [ "x" asc ] key-spec <index-spec> unique-index ensure-index ;
+ "_x_idx" [ "x" asc ] key-spec <index-spec> t >>unique? ensure-index ;
: insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
prepare-collection
USING: accessors assocs fry io.encodings.binary io.sockets kernel math
math.parser mongodb.msg mongodb.operations namespaces destructors
-constructors sequences splitting checksums checksums.md5 formatting
+constructors sequences splitting checksums checksums.md5
io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
arrays hashtables sequences.deep vectors locals ;
mdb-connection get instance>> ; inline
: index-collection ( -- ns )
- mdb-instance name>> "%s.system.indexes" sprintf ; inline
+ mdb-instance name>> "system.indexes" "." glue ; inline
: namespaces-collection ( -- ns )
- mdb-instance name>> "%s.system.namespaces" sprintf ; inline
+ mdb-instance name>> "system.namespaces" "." glue ; inline
: cmd-collection ( -- ns )
- mdb-instance name>> "%s.$cmd" sprintf ; inline
+ mdb-instance name>> "$cmd" "." glue ; inline
: index-ns ( colname -- index-ns )
- [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline
+ [ mdb-instance name>> ] dip "." glue ; inline
: send-message ( message -- )
[ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ;
HELP: create-collection
{ $values
- { "name" "collection name" }
+ { "name/collection" "collection name" }
}
{ $description "Creates a new collection with the given name." } ;
"\"db\" \"127.0.0.1\" 27017 <mdb>"
"[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> ensure-index ] with-db" "" }
{ $unchecked-example "USING: mongodb.driver ;"
- "\"db\" \"127.0.0.1\" 27017 <mdb>" "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> unique-index ensure-index ] with-db" "" } } ;
+ "\"db\" \"127.0.0.1\" 27017 <mdb>" "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> t >>unique? ensure-index ] with-db" "" } } ;
HELP: explain.
{ $values
-USING: accessors assocs bson.constants bson.writer combinators combinators.smart
-constructors continuations destructors formatting fry io io.pools
-io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs hashtables
-namespaces parser prettyprint sequences sets splitting strings uuid arrays
-math math.parser memoize mongodb.connection mongodb.msg mongodb.operations ;
+USING: accessors arrays assocs bson.constants combinators
+combinators.smart constructors destructors formatting fry hashtables
+io io.pools io.sockets kernel linked-assocs math mongodb.connection
+mongodb.msg parser prettyprint sequences sets splitting strings
+tools.continuations uuid memoize locals ;
IN: mongodb.driver
CONSTRUCTOR: index-spec ( ns name key -- index-spec ) ;
-: unique-index ( index-spec -- index-spec )
- t >>unique? ;
-
M: mdb-pool make-connection
mdb>> mdb-open ;
[ make-cursor ] 2tri
swap objects>> ;
+: make-collection-assoc ( collection assoc -- )
+ [ [ name>> "create" ] dip set-at ]
+ [ [ [ capped>> ] keep ] dip
+ '[ _ _
+ [ [ drop t "capped" ] dip set-at ]
+ [ [ size>> "size" ] dip set-at ]
+ [ [ max>> "max" ] dip set-at ] 2tri ] when
+ ] 2bi ;
+
PRIVATE>
SYNTAX: r/ ( token -- mdbregexp )
H{ } clone [ set-at ] keep <mdb-db>
[ verify-nodes ] keep ;
-GENERIC: create-collection ( name -- )
+GENERIC: create-collection ( name/collection -- )
M: string create-collection
<mdb-collection> create-collection ;
M: mdb-collection create-collection
- [ cmd-collection ] dip
- <linked-hash> [
- [ [ name>> "create" ] dip set-at ]
- [ [ [ capped>> ] keep ] dip
- '[ _ _
- [ [ drop t "capped" ] dip set-at ]
- [ [ size>> "size" ] dip set-at ]
- [ [ max>> "max" ] dip set-at ] 2tri ] when
- ] 2bi
- ] keep <mdb-query-msg> 1 >>return# send-query-plain drop ;
-
+ [ [ cmd-collection ] dip
+ <linked-hash> [ make-collection-assoc ] keep
+ <mdb-query-msg> 1 >>return# send-query-plain drop ] keep
+ [ ] [ name>> ] bi mdb-instance collections>> set-at ;
+
: load-collection-list ( -- collection-list )
namespaces-collection
H{ } clone <mdb-query-msg> send-query-plain objects>> ;
: ensure-valid-collection-name ( collection -- )
[ ";$." intersect length 0 > ] keep
- '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline
-
-: (ensure-collection) ( collection -- )
- mdb-instance collections>> dup keys length 0 =
- [ load-collection-list
- [ [ "options" ] dip key? ] filter
- [ [ "name" ] dip at "." split second <mdb-collection> ] map
- over '[ [ ] [ name>> ] bi _ set-at ] each ] [ ] if
- [ dup ] dip key? [ drop ]
- [ [ ensure-valid-collection-name ] keep create-collection ] if ;
-
+ '[ _ "contains invalid characters ( . $ ; )" "." glue throw ] when ; inline
+
+: build-collection-map ( -- assoc )
+ H{ } clone load-collection-list
+ [ [ "name" ] dip at "." split second <mdb-collection> ] map
+ over '[ [ ] [ name>> ] bi _ set-at ] each ;
+
+: ensure-collection-map ( mdb-instance -- assoc )
+ dup collections>> dup keys length 0 =
+ [ drop build-collection-map [ >>collections drop ] keep ]
+ [ nip ] if ;
+
+: (ensure-collection) ( collection mdb-instance -- collection )
+ ensure-collection-map [ dup ] dip key?
+ [ ] [ [ ensure-valid-collection-name ]
+ [ create-collection ]
+ [ ] tri ] if ;
+
: reserved-namespace? ( name -- ? )
[ "$cmd" = ] [ "system" head? ] bi or ;
: check-collection ( collection -- fq-collection )
- dup mdb-collection? [ name>> ] when
- "." split1 over mdb-instance name>> =
- [ nip ] [ drop ] if
- [ ] [ reserved-namespace? ] bi
- [ [ (ensure-collection) ] keep ] unless
- [ mdb-instance name>> ] dip "%s.%s" sprintf ;
+ [let* | instance [ mdb-instance ]
+ instance-name [ instance name>> ] |
+ dup mdb-collection? [ name>> ] when
+ "." split1 over instance-name =
+ [ nip ] [ drop ] if
+ [ ] [ reserved-namespace? ] bi
+ [ instance (ensure-collection) ] unless
+ [ instance-name ] dip "." glue ] ;
: fix-query-collection ( mdb-query -- mdb-query )
[ check-collection ] change-collection ; inline
: user-defined-key-index ( class -- assoc )
mdb-slot-map user-defined-key
[ drop [ "user-defined-key-index" 1 ] dip
- H{ } clone [ set-at ] keep <tuple-index> unique-index
+ H{ } clone [ set-at ] keep <tuple-index> t >>unique?
[ ] [ name>> ] bi H{ } clone [ set-at ] keep
] [ 2drop H{ } clone ] if ;
--- /dev/null
+! Copyright (C) 2009 Maximilian Lupke.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs help.markup help.syntax sequences ;
+IN: sequences.abbrev
+
+HELP: abbrev
+{ $values
+ { "seqs" sequence }
+ { "assoc" assoc }
+}
+{ $description "Calculates an assoc of { prefix sequence } pairs with prefix being an prefix of each element of sequence for each element in " { $snippet "seqs" } "." } ;
+
+HELP: unique-abbrev
+{ $values
+ { "seqs" sequence }
+ { "assoc" assoc }
+}
+{ $description "Calculates an assoc of { prefix { sequence } } pairs with prefix being an unambiguous prefix of sequence in seqs." } ;
+
+ARTICLE: "sequences.abbrev" "Examples of abbrev usage"
+"It is probably easiest to just run examples to understand abbrev."
+{ $code
+ "{ \"hello\" \"help\" } abbrev"
+ "{ \"hello\" \"help\" } unique-abbrev"
+}
+;
+
+ABOUT: "sequences.abbrev"
--- /dev/null
+USING: assocs sequences.abbrev tools.test ;
+IN: sequences.abbrev.tests
+
+[ { "hello" "help" } ] [
+ "he" { "apple" "hello" "help" } abbrev at
+] unit-test
+
+[ f ] [
+ "he" { "apple" "hello" "help" } unique-abbrev at
+] unit-test
+
+[ { "apple" } ] [
+ "a" { "apple" "hello" "help" } abbrev at
+] unit-test
+
+[ { "apple" } ] [
+ "a" { "apple" "hello" "help" } unique-abbrev at
+] unit-test
+
+[ f ] [
+ "a" { "hello" "help" } abbrev at
+] unit-test
+
+[ f ] [
+ "a" { "hello" "help" } unique-abbrev at
+] unit-test
--- /dev/null
+! Copyright (C) 2009 Maximilian Lupke.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays assocs fry kernel math.ranges sequences ;
+IN: sequences.abbrev
+
+<PRIVATE
+
+: prefixes ( seq -- prefixes )
+ dup length [1,b] [ head ] with map ;
+
+: (abbrev) ( seq -- assoc )
+ [ prefixes ] keep 1array '[ _ ] H{ } map>assoc ;
+
+: assoc-merge ( assoc1 assoc2 -- assoc3 )
+ tuck '[ over _ at dup [ append ] [ drop ] if ] assoc-map assoc-union ;
+
+PRIVATE>
+
+: abbrev ( seqs -- assoc )
+ [ (abbrev) ] map H{ } [ assoc-merge ] reduce ;
+
+: unique-abbrev ( seqs -- assoc )
+ abbrev [ nip length 1 = ] assoc-filter ;
--- /dev/null
+Maximilian Lupke
f swap open-window* ;
: into-window ( world quot -- world )
- [ dup handle>> ] dip with-gl-context ; inline
+ [ dup ] dip with-gl-context ; inline
--- /dev/null
+Syntax and combinators for manipulating algebraic data types
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: arrays classes classes.singleton classes.tuple help.markup
+help.syntax kernel multiline slots quotations ;
+IN: variants
+
+HELP: VARIANT:
+{ $syntax <"
+VARIANT: class-name
+ singleton
+ singleton
+ tuple: { slot slot slot ... }
+ .
+ .
+ .
+ ; "> }
+{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots can recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
+{ $examples { $code <"
+USING: kernel variants ;
+IN: scratchpad
+
+VARIANT: list
+ nil
+ cons: { { first object } { rest list } }
+ ;
+"> } } ;
+
+HELP: match
+{ $values { "branches" array } }
+{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with the underlying stack unchanged. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
+{ $examples { $example <"
+USING: kernel math prettyprint variants ;
+IN: scratchpad
+
+VARIANT: list
+ nil
+ cons: { { first object } { rest list } }
+ ;
+
+: list-length ( list -- length )
+ {
+ { nil [ 0 ] }
+ { cons [ nip list-length 1 + ] }
+ } match ;
+
+1 2 3 4 nil <cons> <cons> <cons> <cons> list-length .
+"> "4" } } ;
+
+HELP: unboa
+{ $values { "class" class } }
+{ $description "Decomposes a tuple of type " { $snippet "class" } " into its component slot values by order of arguments. The inverse of " { $link boa } "." } ;
+
+HELP: variant-class
+{ $class-description "This class comprises class names that have been defined with " { $link POSTPONE: VARIANT: } ". When a " { $snippet "variant-class" } " is used as the type of a specialized " { $link tuple } " slot, the variant's first member type is used as the default " { $link initial-value } "." } ;
+
+{ POSTPONE: VARIANT: variant-class match } related-words
+
+ARTICLE: "variants" "Algebraic data types"
+"The " { $vocab-link "variants" } " vocabulary provides syntax and combinators for defining and manipulating algebraic data types."
+{ $subsection POSTPONE: VARIANT: }
+{ $subsection variant-class }
+{ $subsection match } ;
+
+ABOUT: "variants"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: kernel math tools.test variants ;
+IN: variants.tests
+
+VARIANT: list
+ nil
+ cons: { { first object } { rest list } }
+ ;
+
+[ t ] [ nil list? ] unit-test
+[ t ] [ 1 nil <cons> list? ] unit-test
+[ f ] [ 1 list? ] unit-test
+
+: list-length ( list -- length )
+ {
+ { nil [ 0 ] }
+ { cons [ nip list-length 1 + ] }
+ } match ;
+
+[ 4 ]
+[ 5 6 7 8 nil <cons> <cons> <cons> <cons> list-length ] unit-test
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays classes classes.mixin classes.parser
+classes.singleton classes.tuple classes.tuple.parser
+classes.union combinators inverse kernel lexer macros make
+parser quotations sequences slots splitting words ;
+IN: variants
+
+PREDICATE: variant-class < mixin-class "variant" word-prop ;
+
+M: variant-class initial-value*
+ dup members [ no-initial-value ]
+ [ nip first dup word? [ initial-value* ] unless ] if-empty ;
+
+: define-tuple-class-and-boa-word ( class superclass slots -- )
+ pick [ define-tuple-class ] dip
+ dup name>> "<" ">" surround create-in swap define-boa-word ;
+
+: define-variant-member ( member -- class )
+ dup array? [ first3 pick [ define-tuple-class-and-boa-word ] dip ] [ dup define-singleton-class ] if ;
+
+: define-variant-class ( class members -- )
+ [ [ define-mixin-class ] [ t "variant" set-word-prop ] [ ] tri ] dip
+ [ define-variant-member swap add-mixin-instance ] with each ;
+
+: parse-variant-tuple-member ( name -- member )
+ create-class-in tuple
+ "{" expect
+ [ "}" parse-tuple-slots-delim ] { } make
+ 3array ;
+
+: parse-variant-member ( name -- member )
+ ":" ?tail [ parse-variant-tuple-member ] [ create-class-in ] if ;
+
+: parse-variant-members ( -- members )
+ [ scan dup ";" = not ]
+ [ parse-variant-member ] produce nip ;
+
+SYNTAX: VARIANT:
+ CREATE-CLASS
+ parse-variant-members
+ define-variant-class ;
+
+MACRO: unboa ( class -- )
+ <wrapper> \ boa [ ] 2sequence [undo] ;
+
+GENERIC# (match-branch) 1 ( class quot -- class quot' )
+
+M: singleton-class (match-branch)
+ \ drop prefix ;
+M: object (match-branch)
+ over \ unboa [ ] 2sequence prepend ;
+
+: ?class ( object -- class )
+ dup word? [ class ] unless ;
+
+MACRO: match ( branches -- )
+ [ dup callable? [ first2 (match-branch) 2array ] unless ] map
+ [ \ dup \ ?class ] dip \ case [ ] 4sequence ;
+
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel furnace.actions html.forms
-http.server.dispatchers db db.tuples db.types urls
-furnace.redirection multiline http namespaces ;
+USING: accessors furnace.actions furnace.redirection
+html.forms http http.server http.server.dispatchers
+io.directories io.encodings.utf8 io.files io.pathnames
+kernel math.parser multiline namespaces sequences urls ;
IN: webapps.imagebin
-TUPLE: imagebin < dispatcher ;
-
-TUPLE: image id path ;
-
-image "IMAGE" {
- { "id" "ID" INTEGER +db-assigned-id+ }
- { "path" "PATH" { VARCHAR 256 } +not-null+ }
-} define-persistent
+TUPLE: imagebin < dispatcher path n ;
: <uploaded-image-action> ( -- action )
<page-action>
{ imagebin "uploaded-image" } >>template ;
-SYMBOL: my-post-data
+: next-image-path ( -- path )
+ imagebin get
+ [ path>> ] [ n>> number>string ] bi append-path ;
+
+M: imagebin call-responder*
+ [ imagebin set ] [ call-next-method ] bi ;
+
+: move-image ( mime-file -- )
+ next-image-path
+ [ [ temporary-path>> ] dip move-file ]
+ [ [ filename>> ] dip ".txt" append utf8 set-file-contents ] 2bi ;
+
: <upload-image-action> ( -- action )
<page-action>
{ imagebin "upload-image" } >>template
[
-
- ! request get post-data>> my-post-data set-global
- ! image new
- ! "file" value
- ! insert-tuple
+ "file1" param [ move-image ] when*
+ "file2" param [ move-image ] when*
+ "file3" param [ move-image ] when*
"uploaded-image" <redirect>
] >>submit ;
-: <imagebin> ( -- responder )
+: <imagebin> ( image-directory -- responder )
imagebin new-dispatcher
+ swap [ make-directories ] [ >>path ] bi
+ 0 >>n
<upload-image-action> "" add-responder
<upload-image-action> "upload-image" add-responder
<uploaded-image-action> "uploaded-image" add-responder ;
+"resource:images" <imagebin> main-responder set-global
<html>
<head><title>Uploaded</title></head>
<body>
-hi from uploaded-image
+You uploaded something!
</body>
</html>
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel
-cocoa
-cocoa.application
-cocoa.types
-cocoa.classes
-cocoa.windows
-core-graphics.types ;
+USING: cocoa cocoa.application cocoa.types cocoa.classes cocoa.windows
+core-graphics.types kernel math.bitwise ;
IN: webkit-demo
FRAMEWORK: /System/Library/Frameworks/WebKit.framework
WebView -> alloc
rect f f -> initWithFrame:frameName:groupName: ;
+: window-style ( -- n )
+ {
+ NSClosableWindowMask
+ NSMiniaturizableWindowMask
+ NSResizableWindowMask
+ NSTitledWindowMask
+ } flags ;
+
: <WebWindow> ( -- id )
- <WebView> rect <ViewWindow> ;
+ <WebView> rect window-style <ViewWindow> ;
: load-url ( window url -- )
[ -> contentView ] [ <NSString> ] bi* -> setMainFrameURL: ;
syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorArray0,factorQuotation0
-syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
+syn region factorDefn matchgroup=factorDefnDelims start=/\<\(MACRO\|MACRO::\|MEMO:\|MEMO::\|:\|::\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
syn region factorMethod matchgroup=factorMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents
syn region factorGeneric matchgroup=factorGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect
syn region factorGenericN matchgroup=factorGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
-syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MEMO\|:\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
+syn region factorPrivateDefn matchgroup=factorPrivateDefnDelims start=/\<\(MACRO\|MACRO::\|MEMO:\|MEMO::\|:\|::\)\?:\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
syn region factorPrivateMethod matchgroup=factorPrivateMethodDelims start=/\<M:\s\+\S\+\s\+\S\+\>/ end=/\<;\>/ contains=@factorDefnContents contained
syn region factorPGeneric matchgroup=factorPGenericDelims start=/\<GENERIC:\s\+\S\+\>/ end=/$/ contains=factorStackEffect contained
syn region factorPGenericN matchgroup=factorPGenericNDelims start=/\<GENERIC#\s\+\S\+\s\+\d\+\>/ end=/$/ contains=factorStackEffect
"HELP:" "HEX:" "HOOK:"
"IN:" "initial:" "INSTANCE:" "INTERSECTION:"
"LIBRARY:"
- "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "MEMO:" "METHOD:" "MIXIN:"
+ "M:" "M::" "MACRO:" "MACRO::" "MAIN:" "MATH:"
+ "MEMO:" "MEMO:" "METHOD:" "MIXIN:"
"OCT:"
"POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
"QUALIFIED-WITH:" "QUALIFIED:"
(format "%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t)))
(defconst fuel-syntax--method-definition-regex
- "^M: +\\([^ ]+\\) +\\([^ ]+\\)")
+ "^M::? +\\([^ ]+\\) +\\([^ ]+\\)")
(defconst fuel-syntax--integer-regex
"\\_<-?[0-9]+\\_>")
"C-ENUM" "C-STRUCT" "C-UNION"
"FROM" "FUNCTION:"
"INTERSECTION:"
- "M" "MACRO" "MACRO:"
+ "M" "M:" "MACRO" "MACRO:"
"MEMO" "MEMO:" "METHOD"
"SYNTAX"
"PREDICATE" "PRIMITIVE"
(format ":[^ ]* \\([^ ]+\\)\\(%s\\)*" fuel-syntax--stack-effect-regex))
(defconst fuel-syntax--defun-signature-regex
- (format "\\(%s\\|%s\\)" fuel-syntax--word-signature-regex "M[^:]*: [^ ]+ [^ ]+"))
+ (format "\\(%s\\|%s\\)"
+ fuel-syntax--word-signature-regex
+ "M[^:]*: [^ ]+ [^ ]+"))
(defconst fuel-syntax--constructor-decl-regex
"\\_<C: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")
box_alien(ffi_dlsym(NULL,sym));
else
{
- tagged<dll> d = library.as<dll>();
- d.untag_check();
+ dll *d = untag_check<dll>(library.value());
if(d->dll == NULL)
dpush(F);
else
- box_alien(ffi_dlsym(d.untagged(),sym));
+ box_alien(ffi_dlsym(d,sym));
}
}
/* close a native library handle */
PRIMITIVE(dlclose)
{
- ffi_dlclose(untag_check<dll>(dpop()));
+ dll *d = untag_check<dll>(dpop());
+ if(d->dll != NULL)
+ ffi_dlclose(d);
}
PRIMITIVE(dll_validp)
if(library == F)
dpush(T);
else
- dpush(
tagged<dll>(library)->dll == NULL ? F : T);
+ dpush(
untag_check<dll>(library)->dll == NULL ? F : T);
}
/* gets the address of an object representing a C pointer */
PRIMITIVE(fixnum_shift)
{
- fixnum y = untag_fixnum(dpop()); \
+ fixnum y = untag_fixnum(dpop());
fixnum x = untag_fixnum(dpeek());
if(x == 0)
projects / factor.git / commitdiff