<plist version="1.0">
<dict>
<key>IBFramework Version</key>
- <string>629</string>
+ <string>677</string>
<key>IBOldestOS</key>
<integer>5</integer>
<key>IBOpenObjects</key>
- <array>
- <integer>305</integer>
- </array>
+ <array/>
<key>IBSystem Version</key>
- <string>9G55</string>
+ <string>9J61</string>
<key>targetFramework</key>
<string>IBCocoaFramework</string>
</dict>
-{
- IBClasses = (
- {
- ACTIONS = {
- newFactorWorkspace = id;
- runFactorFile = id;
- saveFactorImage = id;
- saveFactorImageAs = id;
- showFactorHelp = id;
- };
- CLASS = FirstResponder;
- LANGUAGE = ObjC;
- SUPERCLASS = NSObject;
- }
- );
- IBVersion = 1;
-}
\ No newline at end of file
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+ <key>IBClasses</key>
+ <array>
+ <dict>
+ <key>ACTIONS</key>
+ <dict>
+ <key>newFactorWorkspace</key>
+ <string>id</string>
+ <key>runFactorFile</key>
+ <string>id</string>
+ <key>saveFactorImage</key>
+ <string>id</string>
+ <key>saveFactorImageAs</key>
+ <string>id</string>
+ <key>showFactorHelp</key>
+ <string>id</string>
+ </dict>
+ <key>CLASS</key>
+ <string>FirstResponder</string>
+ <key>LANGUAGE</key>
+ <string>ObjC</string>
+ <key>SUPERCLASS</key>
+ <string>NSObject</string>
+ </dict>
+ </array>
+ <key>IBVersion</key>
+ <string>1</string>
+</dict>
+</plist>
<?xml version="1.0" encoding="UTF-8"?>
-<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<plist version="1.0">
<dict>
- <key>IBDocumentLocation</key>
- <string>1266 155 525 491 0 0 2560 1578 </string>
- <key>IBEditorPositions</key>
- <dict>
- <key>29</key>
- <string>326 905 270 44 0 0 2560 1578 </string>
- </dict>
<key>IBFramework Version</key>
- <string>439.0</string>
+ <string>677</string>
+ <key>IBOldestOS</key>
+ <integer>5</integer>
<key>IBOpenObjects</key>
<array>
- <integer>29</integer>
+ <integer>293</integer>
</array>
<key>IBSystem Version</key>
- <string>8R218</string>
+ <string>9J61</string>
+ <key>targetFramework</key>
+ <string>IBCocoaFramework</string>
</dict>
</plist>
! 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
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs effects grouping kernel
-parser sequences splitting words fry locals lexer namespaces ;
+parser sequences splitting words fry locals lexer namespaces
+summary math ;
IN: alien.parser
+: normalize-c-arg ( type name -- type' name' )
+ [ length ]
+ [
+ [ CHAR: * = ] trim-head
+ [ length - CHAR: * <array> append ] keep
+ ] bi ;
+
: parse-arglist ( parameters return -- types effect )
- [ 2 group unzip [ "," ?tail drop ] map ]
+ [
+ 2 group [ first2 normalize-c-arg 2array ] map
+ unzip [ "," ?tail drop ] map
+ ]
[ [ { } ] [ 1array ] if-void ]
bi* <effect> ;
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
-:: make-function ( return library function parameters -- word quot effect )
+:: make-function ( return! library function! parameters -- word quot effect )
+ return function normalize-c-arg function! return!
function create-in dup reset-generic
return library function
parameters return parse-arglist [ function-quot ] dip ;
}
"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
[ [ length bits>cells ] keep ] dip swap underlying>>
'[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
+: clean-up ( bit-array -- )
+ ! Zero bits after the end.
+ dup underlying>> empty? [ drop ] [
+ [
+ [ underlying>> length 8 * ] [ length ] bi -
+ 8 swap - -1 swap shift bitnot
+ ]
+ [ underlying>> last bitand ]
+ [ underlying>> set-last ]
+ tri
+ ] if ; inline
+
PRIVATE>
: <bit-array> ( n -- bit-array )
[ byte/bit set-bit ] 2keep
swap n>byte set-alien-unsigned-1 ;
-: clear-bits ( bit-array -- ) 0 (set-bits) ;
+GENERIC: clear-bits ( bit-array -- )
+
+M: bit-array clear-bits 0 (set-bits) ;
+
+GENERIC: set-bits ( bit-array -- )
-: set-bits ( bit-array -- ) -1 (set-bits) ;
+M: bit-array set-bits -1 (set-bits) ;
M: bit-array clone
[ length>> ] [ underlying>> clone ] bi bit-array boa ;
M: bit-array new-sequence drop <bit-array> ;
M: bit-array equal?
- over bit-array? [ sequence= ] [ 2drop f ] if ;
+ over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ;
M: bit-array resize
[ drop ] [
[ bits>bytes ] [ underlying>> ] bi*
resize-byte-array
] 2bi
- bit-array boa ;
+ bit-array boa
+ dup clean-up ;
M: bit-array byte-length length 7 + -3 shift ;
--- /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 ;
+
+: bit-set-subset? ( seq1 seq2 -- ? ) dupd bit-set-intersect = ;
\ 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
--- /dev/null
+Maxim Savchenko
+Slava Pestov
--- /dev/null
+! Copyright (C) 2009 Maxim Savchenko, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: byte-arrays.hex
+USING: byte-arrays help.markup help.syntax ;
+
+HELP: HEX{
+{ $syntax "HEX{ 0123 45 67 89abcdef }" }
+{ $description "Constructs a " { $link byte-array } " from data specified in hexadecimal format. Whitespace between the curly braces is ignored." } ;
--- /dev/null
+! Copyright (C) 2009 Maxim Savchenko, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: grouping lexer ascii parser sequences kernel math.parser ;
+IN: byte-arrays.hex
+
+SYNTAX: HEX{
+ "}" parse-tokens "" join
+ [ blank? not ] filter
+ 2 group [ hex> ] B{ } map-as
+ parsed ;
+
<cairo> &cairo_destroy
@
] make-memory-bitmap
- BGRA >>component-order ; inline
+ BGRA >>component-order
+ ubyte-components >>component-type ; inline
: dummy-cairo ( -- cr )
#! Sometimes we want a dummy context; eg with Pango, we want
cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
FUNCTION: cairo_status_t
-cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
+cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t** surface ) ;
FUNCTION: cairo_status_t
cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax arrays calendar
-kernel math unix unix.time namespaces system ;
+kernel math unix unix.time unix.types namespaces system ;
IN: calendar.unix
: timeval>seconds ( timeval -- seconds )
timespec>seconds since-1970 ;
: get-time ( -- alien )
- f time <uint> localtime ;
+ f time <time_t> localtime ;
: timezone-name ( -- string )
get-time tm-zone ;
! 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
M: growing-circular length length>> ;
<PRIVATE
+
: full? ( circular -- ? )
[ length ] [ seq>> length ] bi = ;
-: set-last ( elt seq -- )
- [ length 1- ] keep set-nth ;
PRIVATE>
: push-growing-circular ( elt circular -- )
! 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.
+: join-block? ( bb -- ? )
+ {
+ [ kill-block? not ]
+ [ predecessors>> length 1 = ]
+ [ predecessor kill-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-instructions ( insns -- insns' )
+ [ clone dup rename-insn-temps ] map ;
+
+: clone-basic-block ( bb -- bb' )
+ ! The new block temporarily gets the same RPO number as the old one,
+ ! until the next time RPO is computed. 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 <= ;
+
+: short-tail-block? ( bb -- ? )
+ [ successors>> empty? ] [ instructions>> length 2 = ] bi and ;
+
+: short-block? ( bb -- ? )
+ ! If block is empty, always split
+ [ predecessors>> length ] [ instructions>> length 1 - ] bi * 10 <= ;
+
+: cond-cond-block? ( bb -- ? )
+ {
+ [ predecessors>> length 2 = ]
+ [ successors>> length 2 = ]
+ [ instructions>> length 20 <= ]
+ } 1&& ;
+
+: split-branch? ( bb -- ? )
+ dup loop-entry? [ drop f ] [
+ dup predecessors>> length 1 <= [ drop f ] [
+ {
+ [ short-block? ]
+ [ short-tail-block? ]
+ [ cond-cond-block? ]
+ } 1||
+ ] if
+ ] if ;
+
+: 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
GENERIC: compute-stack-frame* ( insn -- )
: request-stack-frame ( stack-frame -- )
+ frame-required? on
stack-frame [ max-stack-frame ] change ;
-M: ##stack-frame compute-stack-frame*
- frame-required? on
+M: ##alien-invoke compute-stack-frame*
+ stack-frame>> request-stack-frame ;
+
+M: ##alien-indirect compute-stack-frame*
+ stack-frame>> request-stack-frame ;
+
+M: ##alien-callback compute-stack-frame*
stack-frame>> request-stack-frame ;
M: ##call compute-stack-frame*
] 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
GENERIC: insert-pro/epilogues* ( insn -- )
-M: ##stack-frame insert-pro/epilogues* drop ;
-
M: ##prologue insert-pro/epilogues*
drop frame-required? get [ stack-frame get _prologue ] when ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays fry kernel make math namespaces sequences
+compiler.cfg compiler.cfg.instructions compiler.cfg.stacks
+compiler.cfg.stacks.local ;
+IN: compiler.cfg.builder.blocks
+
+: set-basic-block ( basic-block -- )
+ [ basic-block set ] [ instructions>> building set ] bi
+ begin-local-analysis ;
+
+: initial-basic-block ( -- )
+ <basic-block> set-basic-block ;
+
+: end-basic-block ( -- )
+ basic-block get [ end-local-analysis ] when
+ building off
+ basic-block off ;
+
+: (begin-basic-block) ( -- )
+ <basic-block>
+ basic-block get [ dupd successors>> push ] when*
+ set-basic-block ;
+
+: begin-basic-block ( -- )
+ basic-block get [ end-local-analysis ] when
+ (begin-basic-block) ;
+
+: emit-trivial-block ( quot -- )
+ ##branch begin-basic-block
+ call
+ ##branch begin-basic-block ; inline
+
+: call-height ( #call -- n )
+ [ out-d>> length ] [ in-d>> length ] bi - ;
+
+: emit-primitive ( node -- )
+ [
+ [ word>> ##call ]
+ [ call-height adjust-d ] bi
+ ] emit-trivial-block ;
+
+: begin-branch ( -- ) clone-current-height (begin-basic-block) ;
+
+: end-branch ( -- pair/f )
+ ! pair is { final-bb final-height }
+ basic-block get dup [
+ ##branch
+ end-local-analysis
+ current-height get clone 2array
+ ] when ;
+
+: with-branch ( quot -- pair/f )
+ [ begin-branch call end-branch ] with-scope ; inline
+
+: set-successors ( branches -- )
+ ! Set the successor of each branch's final basic block to the
+ ! current block.
+ basic-block get dup [
+ '[ [ [ _ ] dip first successors>> push ] when* ] each
+ ] [ 2drop ] if ;
+
+: merge-heights ( branches -- )
+ ! If all elements are f, that means every branch ended with a backward
+ ! jump so the height is irrelevant since this block is unreachable.
+ [ ] find nip [ second current-height set ] [ end-basic-block ] if* ;
+
+: emit-conditional ( branches -- )
+ ! branchies is a sequence of pairs as above
+ end-basic-block
+ [ merge-heights begin-basic-block ]
+ [ set-successors ]
+ bi ;
+
IN: compiler.cfg.builder.tests
-USING: tools.test kernel sequences
-words sequences.private fry prettyprint alien alien.accessors
-math.private compiler.tree.builder compiler.tree.optimizer
-compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays
-kernel.private math ;
+USING: tools.test kernel sequences words sequences.private fry
+prettyprint alien alien.accessors math.private compiler.tree.builder
+compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
+compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
+arrays locals byte-arrays kernel.private math slots.private vectors sbufs
+strings math.partial-dispatch strings.private ;
! Just ensure that various CFGs build correctly.
-: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ;
+: unit-test-cfg ( quot -- )
+ '[ _ test-cfg [ optimize-cfg check-cfg ] each ] [ ] swap unit-test ;
+
+: blahblah ( nodes -- ? )
+ { fixnum } declare [
+ dup 3 bitand 1 = [ drop t ] [
+ dup 3 bitand 2 = [
+ blahblah
+ ] [ drop f ] if
+ ] if
+ ] any? ; inline recursive
+
+: more? ( x -- ? ) ;
+
+: test-case-1 ( -- ? ) f ;
+
+: test-case-2 ( -- )
+ test-case-1 [ test-case-2 ] [ ] if ; inline recursive
{
[ ]
[ 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? ]
[ "int" f "malloc" { "int" } alien-invoke ]
[ "int" { "int" } "cdecl" alien-indirect ]
[ "int" { "int" } "cdecl" [ ] alien-callback ]
+ [ swap - + * ]
+ [ swap slot ]
+ [ blahblah ]
+ [ 1000 [ dup [ reverse ] when ] times ]
+ [ 1array ]
+ [ 1 2 ? ]
+ [ { array } declare [ ] map ]
+ [ { array } declare dup 1 slot [ 1 slot ] when ]
+ [ [ dup more? ] [ dup ] produce ]
+ [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
+ [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
+ [
+ { fixnum sbuf } declare 2dup 3 slot fixnum> [
+ over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
+ ] [ ] if
+ ]
+ [ [ 2 fixnum* ] when 3 ]
+ [ [ 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
+ ]
} [
unit-test-cfg
] each
-! 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.tree.propagation.info
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.cfg.predecessors
+compiler.cfg.builder.blocks
+compiler.cfg.stacks
compiler.alien ;
IN: compiler.cfg.builder
-! Convert tree SSA IR to CFG SSA IR.
+! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is
+! constructed later by calling compiler.cfg.ssa.construction:construct-ssa.
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-cfg ( word label -- cfg )
+ initial-basic-block
+ H{ } clone loops set
+ [ basic-block get ] 2dip <cfg> dup cfg set ;
: begin-procedure ( word label -- )
- end-basic-block
- begin-basic-block
- H{ } clone loops set
- current-label set
- current-word set
- add-procedure ;
+ begin-cfg procedures get push ;
: with-cfg-builder ( nodes word label quot -- )
- '[ begin-procedure @ ] with-scope ; inline
-
-GENERIC: emit-node ( node -- next )
+ '[
+ begin-stack-analysis
+ begin-procedure
+ @
+ end-stack-analysis
+ ] with-scope ; inline
-: 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 ;
+ end-basic-block ;
-: 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 height -- )
+ over loops get key?
+ [ drop loops get at emit-loop-call ]
+ [ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ]
+ if ;
! #recursive
: recursive-height ( #recursive -- n )
[ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
-: emit-recursive ( #recursive -- next )
+: emit-recursive ( #recursive -- )
[ [ label>> id>> ] [ recursive-height ] bi 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 )
- ##loop-entry
+: emit-loop ( node -- )
##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 ;
-
-: ##branch-t ( vreg -- )
- \ f tag-number cc/= ##compare-imm-branch ;
+ children>> [ emit-branch ] map emit-conditional ;
: trivial-branch? ( nodes -- value ? )
dup length 1 = [
: emit-trivial-not-if ( -- )
ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
+: emit-actual-if ( #if -- )
+ ! Inputs to the final instruction need to be copied because of
+ ! loc>vreg sync
+ ds-pop ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
+
M: #if emit-node
{
{ [ 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 ;
+ [ emit-actual-if ]
+ } cond ;
! #dispatch
M: #dispatch emit-node
- ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
+ ! Inputs to the final instruction need to be copied because of
+ ! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
+ ! though.
+ ds-pop ^^offset>slot i ##dispatch emit-if ;
! #call
M: #call emit-node
! #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 ;
+: emit-return ( -- )
+ ##branch begin-basic-block ##epilogue ##return ;
+
+M: #return emit-node drop emit-return ;
M: #return-recursive emit-node
- label>> id>> loops get key?
- [ iterate-next ] [ ##epilogue ##return stop-iterating ] if ;
+ label>> id>> loops get key? [ emit-return ] unless ;
! #terminate
-M: #terminate emit-node drop stop-iterating ;
+M: #terminate emit-node drop ##no-tco end-basic-block ;
! FFI
: return-size ( ctype -- n )
[ return>> return-size >>return ]
[ alien-parameters parameter-sizes drop >>params ] bi ;
-: alien-stack-frame ( params -- )
- <alien-stack-frame> ##stack-frame ;
+: alien-node-height ( params -- )
+ [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
-: emit-alien-node ( node quot -- next )
- [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
- ##branch begin-basic-block iterate-next ; inline
+: emit-alien-node ( node quot -- )
+ [
+ [ params>> dup dup <alien-stack-frame> ] dip call
+ alien-node-height
+ ] emit-trivial-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
-combinators.short-circuit accessors math sequences sets assocs ;
+compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities
+compiler.cfg.mr combinators.short-circuit accessors math
+sequences sets assocs ;
IN: compiler.cfg.checker
-ERROR: last-insn-not-a-jump insn ;
+ERROR: bad-kill-block bb ;
+
+: check-kill-block ( bb -- )
+ dup instructions>> first2
+ swap ##epilogue? [
+ { [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1||
+ ] [ ##branch? ] if
+ [ drop ] [ bad-kill-block ] if ;
+
+ERROR: last-insn-not-a-jump bb ;
: check-last-instruction ( bb -- )
- last dup {
+ dup instructions>> last {
[ ##branch? ]
[ ##dispatch? ]
[ ##conditional-branch? ]
[ ##compare-imm-branch? ]
- [ ##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 ;
+ERROR: bad-kill-insn bb ;
+
+: check-kill-instructions ( bb -- )
+ dup instructions>> [ kill-vreg-insn? ] any?
+ [ bad-kill-insn ] [ drop ] if ;
-: check-loop-entry ( bb -- )
- dup length 2 >= [
- 2 head* [ ##loop-entry? ] any?
- [ bad-loop-entry ] when
- ] [ drop ] if ;
+: check-normal-block ( bb -- )
+ [ check-last-instruction ]
+ [ check-kill-instructions ]
+ bi ;
ERROR: bad-successors ;
[ bad-successors ] unless ;
: check-basic-block ( bb -- )
- [ instructions>> check-last-instruction ]
- [ instructions>> check-loop-entry ]
+ [ dup kill-block? [ check-kill-block ] [ check-normal-block ] if ]
[ check-successors ]
- tri ;
+ bi ;
ERROR: bad-live-in ;
! Check that every used register has a definition
instructions>>
[ [ uses-vregs ] map concat ]
- [ [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat ] bi
+ [ [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ] map concat ] bi
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 ;
+ [ build-mr check-mr ]
+ 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
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces assocs accessors ;
+USING: kernel namespaces assocs accessors sequences grouping
+compiler.cfg.rpo compiler.cfg.renaming compiler.cfg.instructions ;
IN: compiler.cfg.copy-prop
+! The first three definitions are also used in compiler.cfg.alias-analysis.
SYMBOL: copies
: resolve ( vreg -- vreg )
- [ copies get at ] keep or ;
+ copies get ?at drop ;
-: record-copy ( insn -- )
- [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
+: (record-copy) ( dst src -- )
+ swap copies get set-at ; inline
+
+: record-copy ( ##copy -- )
+ [ dst>> ] [ src>> resolve ] bi (record-copy) ; inline
+
+<PRIVATE
+
+GENERIC: visit-insn ( insn -- )
+
+M: ##copy visit-insn record-copy ;
+
+M: ##phi visit-insn
+ [ dst>> ] [ inputs>> values [ resolve ] map ] bi
+ dup all-equal? [ first (record-copy) ] [ 2drop ] if ;
+
+M: insn visit-insn drop ;
+
+: collect-copies ( cfg -- )
+ H{ } clone copies set
+ [
+ instructions>>
+ [ visit-insn ] each
+ ] each-basic-block ;
+
+GENERIC: update-insn ( insn -- keep? )
+
+M: ##copy update-insn drop f ;
+
+M: ##phi update-insn
+ dup dst>> copies get key? [ drop f ] [ call-next-method ] if ;
+
+M: insn update-insn rename-insn-uses t ;
+
+: rename-copies ( cfg -- )
+ copies get dup assoc-empty? [ 2drop ] [
+ renamings set
+ [
+ instructions>>
+ [ update-insn ] filter-here
+ ] each-basic-block
+ ] if ;
+
+PRIVATE>
+
+: copy-propagation ( cfg -- cfg' )
+ [ collect-copies ]
+ [ rename-copies ]
+ [ ]
+ tri ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math accessors sequences
+compiler.cfg compiler.cfg.rpo compiler.cfg.utilities ;
+IN: compiler.cfg.critical-edges
+
+: critical-edge? ( from to -- ? )
+ [ successors>> length 1 > ] [ predecessors>> length 1 > ] bi* and ;
+
+: split-critical-edge ( from to -- )
+ f <simple-block> insert-basic-block ;
+
+: split-critical-edges ( cfg -- )
+ dup [
+ dup successors>> [
+ 2dup critical-edge?
+ [ split-critical-edge ] [ 2drop ] if
+ ] with each
+ ] each-basic-block
+ cfg-changed
+ drop ;
\ 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 )
M: callable test-cfg
+ 0 vreg-counter set-global
build-tree optimize-tree gensym build-cfg ;
M: word test-cfg
+ 0 vreg-counter set-global
[ build-tree optimize-tree ] keep build-cfg ;
: test-mr ( quot -- mrs )
] 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 namespaces fry
+sets compiler.cfg.rpo compiler.cfg.instructions ;
IN: compiler.cfg.def-use
-GENERIC: defs-vregs ( insn -- seq )
+GENERIC: defs-vreg ( insn -- vreg/f )
GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
-M: ##flushable defs-vregs dst>> 1array ;
-M: insn defs-vregs drop f ;
+M: ##flushable defs-vreg dst>> ;
+M: ##fixnum-overflow defs-vreg dst>> ;
+M: _fixnum-overflow defs-vreg dst>> ;
+M: insn defs-vreg drop f ;
M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
M: ##unary/temp temp-vregs temp>> 1array ;
M: ##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 ;
M: insn uses-vregs drop f ;
-! Instructions that use vregs
-UNION: vreg-insn
-##flushable
-##write-barrier
-##dispatch
-##effect
-##fixnum-overflow
-##conditional-branch
-##compare-imm-branch
-##phi
-##gc
-_conditional-branch
-_compare-imm-branch
-_dispatch ;
+! Computing def-use chains.
+
+SYMBOLS: defs insns uses ;
+
+: def-of ( vreg -- node ) defs get at ;
+: uses-of ( vreg -- nodes ) uses get at ;
+: insn-of ( vreg -- insn ) insns get at ;
+
+: set-def-of ( obj insn assoc -- )
+ swap defs-vreg dup [ swap set-at ] [ 3drop ] if ;
+
+: compute-defs ( cfg -- )
+ H{ } clone [
+ '[
+ dup instructions>> [
+ _ set-def-of
+ ] with each
+ ] each-basic-block
+ ] keep
+ defs set ;
+
+: compute-insns ( cfg -- )
+ H{ } clone [
+ '[
+ instructions>> [
+ dup _ set-def-of
+ ] each
+ ] each-basic-block
+ ] keep insns set ;
+
+: compute-uses ( cfg -- )
+ H{ } clone [
+ '[
+ dup instructions>> [
+ uses-vregs [
+ _ conjoin-at
+ ] with each
+ ] with each
+ ] each-basic-block
+ ] keep
+ [ keys ] assoc-map
+ uses set ;
+
+: compute-def-use ( cfg -- )
+ [ compute-defs ] [ compute-uses ] [ compute-insns ] tri ;
\ No newline at end of file
--- /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
+
+[ t ] [ 0 get 3 get dominates? ] unit-test
+[ f ] [ 3 get 4 get dominates? ] unit-test
+[ f ] [ 1 get 4 get dominates? ] unit-test
+[ t ] [ 4 get 5 get dominates? ] unit-test
+[ f ] [ 1 get 5 get dominates? ] 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
! 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 vectors namespaces sequences sorting locals
+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 ;
+
+SYMBOLS: preorder maxpreorder ;
+
+PRIVATE>
+
+: pre-of ( bb -- n ) [ preorder get at ] [ -1/0. ] if* ;
+
+: maxpre-of ( bb -- n ) [ maxpreorder get at ] [ 1/0. ] if* ;
+
+<PRIVATE
+
+: (compute-dfs) ( n bb -- n )
+ [ 1 + ] dip
+ [ dupd preorder get set-at ]
+ [ dom-children [ (compute-dfs) ] each ]
+ [ dupd maxpreorder get set-at ]
+ tri ;
+
+: compute-dfs ( cfg -- )
+ H{ } clone preorder set
+ H{ } clone maxpreorder set
+ [ 0 ] dip entry>> (compute-dfs) drop ;
+
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
+: compute-dominance ( cfg -- )
+ [ compute-dom-parents compute-dom-children ] [ compute-dfs ] bi ;
+
+: dominates? ( bb1 bb2 -- ? )
+ swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ;
+
+:: breadth-first-order ( cfg -- bfo )
+ <dlist> :> work-list
+ cfg post-order length <vector> :> accum
+ cfg entry>> work-list push-front
+ work-list [
+ [ accum push ]
+ [ dom-children work-list push-all-front ] bi
+ ] slurp-deque
+ accum ;
\ 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.empty-blocks
+
+: update-predecessor ( 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 ( 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 ] [ update-successor ] bi ;
+
+: delete-basic-block? ( bb -- ? )
+ {
+ [ instructions>> length 1 = ]
+ [ predecessors>> length 1 = ]
+ [ successors>> length 1 = ]
+ [ instructions>> first ##branch? ]
+ } 1&& ;
+
+: delete-empty-blocks ( cfg -- cfg' )
+ dup [ dup delete-basic-block? [ delete-basic-block ] [ drop ] if ] each-basic-block
+ cfg-changed ;
\ 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' )
: ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline
: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
-: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline
+: ^^copy ( src -- dst ) ^^i1 ##copy ; inline
: ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
: ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
: ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
: ^^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
: ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
: ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
: ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
-: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
+: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; 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
compiler.cfg.instructions.syntax ;
IN: compiler.cfg.instructions
-: new-insn ( ... class -- insn ) [ f f ] dip boa ; inline
+: new-insn ( ... class -- insn ) f swap boa ; inline
! Virtual CPU instructions, used by CFG and machine IRs
TUPLE: insn ;
! Instruction with no side effects; if 'out' is never read, we
! can eliminate it.
-TUPLE: ##flushable < insn { dst vreg } ;
+TUPLE: ##flushable < insn dst ;
! Instruction which is referentially transparent; we can replace
! repeated computation with a reference to a previous value
TUPLE: ##pure < ##flushable ;
-TUPLE: ##unary < ##pure { src vreg } ;
-TUPLE: ##unary/temp < ##unary { temp vreg } ;
-TUPLE: ##binary < ##pure { src1 vreg } { src2 vreg } ;
-TUPLE: ##binary-imm < ##pure { src1 vreg } { src2 integer } ;
+TUPLE: ##unary < ##pure src ;
+TUPLE: ##unary/temp < ##unary temp ;
+TUPLE: ##binary < ##pure src1 src2 ;
+TUPLE: ##binary-imm < ##pure src1 { src2 integer } ;
TUPLE: ##commutative < ##binary ;
TUPLE: ##commutative-imm < ##binary-imm ;
! Instruction only used for its side effect, produces no values
-TUPLE: ##effect < insn { src vreg } ;
+TUPLE: ##effect < insn src ;
! Read/write ops: candidates for alias analysis
TUPLE: ##read < ##flushable ;
TUPLE: ##write < ##effect ;
-TUPLE: ##alien-getter < ##flushable { src vreg } ;
-TUPLE: ##alien-setter < ##effect { value vreg } ;
+TUPLE: ##alien-getter < ##flushable src ;
+TUPLE: ##alien-setter < ##effect value ;
! Stack operations
INSN: ##load-immediate < ##pure { val integer } ;
INSN: ##inc-r { n integer } ;
! 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 ;
! Slot access
-INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
-INSN: ##slot-imm < ##read { obj vreg } { slot integer } { tag integer } ;
-INSN: ##set-slot < ##write { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
-INSN: ##set-slot-imm < ##write { obj vreg } { slot integer } { tag integer } ;
+INSN: ##slot < ##read obj slot { tag integer } temp ;
+INSN: ##slot-imm < ##read obj { slot integer } { tag integer } ;
+INSN: ##set-slot < ##write obj slot { tag integer } temp ;
+INSN: ##set-slot-imm < ##write obj { slot integer } { tag integer } ;
! String element access
-INSN: ##string-nth < ##flushable { obj vreg } { index vreg } { temp vreg } ;
-INSN: ##set-string-nth-fast < ##effect { obj vreg } { index vreg } { temp vreg } ;
+INSN: ##string-nth < ##flushable obj index temp ;
+INSN: ##set-string-nth-fast < ##effect obj index temp ;
! Integer arithmetic
INSN: ##add < ##commutative ;
INSN: ##or-imm < ##commutative-imm ;
INSN: ##xor < ##commutative ;
INSN: ##xor-imm < ##commutative-imm ;
+INSN: ##shl < ##binary ;
INSN: ##shl-imm < ##binary-imm ;
+INSN: ##shr < ##binary ;
INSN: ##shr-imm < ##binary-imm ;
+INSN: ##sar < ##binary ;
INSN: ##sar-imm < ##binary-imm ;
INSN: ##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: ##set-alien-double < ##alien-setter ;
! Memory allocation
-INSN: ##allot < ##flushable size class { temp vreg } ;
+INSN: ##allot < ##flushable size class temp ;
UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
INSN: ##alien-global < ##flushable symbol library ;
! FFI
-INSN: ##alien-invoke params ;
-INSN: ##alien-indirect params ;
-INSN: ##alien-callback params ;
+INSN: ##alien-invoke params stack-frame ;
+INSN: ##alien-indirect params stack-frame ;
+INSN: ##alien-callback params stack-frame ;
INSN: ##callback-return params ;
! Instructions used by CFG IR only.
INSN: ##branch ;
-INSN: ##loop-entry ;
-
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? ;
-
-TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ;
+! Conditionals
+TUPLE: ##conditional-branch < insn src1 src2 cc ;
INSN: ##compare-branch < ##conditional-branch ;
-INSN: ##compare-imm-branch { src1 vreg } { src2 integer } cc ;
+INSN: ##compare-imm-branch src1 { src2 integer } cc ;
INSN: ##compare < ##binary cc temp ;
INSN: ##compare-imm < ##binary-imm cc temp ;
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 src1 src2 ;
+INSN: ##fixnum-add < ##fixnum-overflow ;
+INSN: ##fixnum-sub < ##fixnum-overflow ;
+INSN: ##fixnum-mul < ##fixnum-overflow ;
+
+INSN: ##gc temp1 temp2 live-values ;
! Instructions used by machine IR only.
INSN: _prologue stack-frame ;
INSN: _label id ;
INSN: _branch label ;
+INSN: _loop-entry ;
INSN: _dispatch src temp ;
INSN: _dispatch-label label ;
-TUPLE: _conditional-branch < insn label { src1 vreg } { src2 vreg } cc ;
+TUPLE: _conditional-branch < insn label src1 src2 cc ;
INSN: _compare-branch < _conditional-branch ;
-INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ;
+INSN: _compare-imm-branch label src1 { src2 integer } cc ;
INSN: _compare-float-branch < _conditional-branch ;
+! Overflowing arithmetic
+TUPLE: _fixnum-overflow < insn label dst src1 src2 ;
+INSN: _fixnum-add < _fixnum-overflow ;
+INSN: _fixnum-sub < _fixnum-overflow ;
+INSN: _fixnum-mul < _fixnum-overflow ;
+
TUPLE: spill-slot n ; C: <spill-slot> spill-slot
-INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ;
+INSN: _gc temp1 temp2 gc-roots gc-root-count gc-root-size ;
! These instructions operate on machine registers and not
! virtual registers
INSN: _reload dst class n ;
INSN: _copy dst src class ;
INSN: _spill-counts counts ;
+
+! Instructions that use vregs
+UNION: vreg-insn
+ ##flushable
+ ##write-barrier
+ ##dispatch
+ ##effect
+ ##fixnum-overflow
+ ##conditional-branch
+ ##compare-imm-branch
+ ##phi
+ ##gc
+ _conditional-branch
+ _compare-imm-branch
+ _dispatch ;
+
+! Instructions that kill all live vregs
+UNION: kill-vreg-insn
+ ##call
+ ##prologue
+ ##epilogue
+ ##alien-invoke
+ ##alien-indirect
+ ##alien-callback ;
+
+! Instructions that have complex expansions and require that the
+! output registers are not equal to any of the input registers
+UNION: def-is-use-insn
+ ##integer>bignum
+ ##bignum>integer
+ ##unbox-any-c-ptr ;
\ No newline at end of file
"insn" "compiler.cfg.instructions" lookup ;
: insn-effect ( word -- effect )
- boa-effect in>> 2 head* f <effect> ;
+ boa-effect in>> but-last f <effect> ;
SYNTAX: INSN:
- parse-tuple-definition { "regs" "insn#" } append
+ parse-tuple-definition "insn#" suffix
[ dup tuple eq? [ drop insn-word ] when ] dip
[ define-tuple-class ]
[ 2drop save-location ]
- [ 2drop [ ] [ '[ f f _ boa , ] ] [ insn-effect ] tri define-inline ]
+ [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
3tri ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences alien math classes.algebra
-fry locals combinators cpu.architecture
-compiler.tree.propagation.info
+USING: accessors kernel sequences alien math classes.algebra fry
+locals combinators cpu.architecture compiler.tree.propagation.info
compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
-compiler.cfg.utilities ;
+compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.alien
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order sequences accessors arrays
byte-arrays layouts classes.tuple.private fry locals
compiler.tree.propagation.info compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.stacks
-compiler.cfg.utilities ;
+compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.allot
: ##set-slots ( regs obj class -- )
-! 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.builder.blocks
+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 ( -- )
+ ds-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 )
+ [ ds-drop ds-drop ds-push ] with-branch ;
+
+: emit-overflow-case ( word -- final-bb )
+ [ ##call -1 adjust-d ] with-branch ;
+
+: emit-fixnum-overflow-op ( quot word -- )
+ ! Inputs to the final instruction need to be copied because
+ ! of loc>vreg sync
+ [ [ (2inputs) [ ^^copy ] bi@ ] dip call ] dip
+ [ 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
strings.private:string-nth
strings.private:set-string-nth-fast
- classes.tuple.private:<tuple-boa>
- arrays:<array>
- byte-arrays:<byte-array>
- byte-arrays:(byte-array)
- kernel:<wrapper>
+ ! classes.tuple.private:<tuple-boa>
+ ! byte-arrays:<byte-array>
+ ! byte-arrays:(byte-array)
+ ! kernel:<wrapper>
alien.accessors:alien-unsigned-1
alien.accessors:set-alien-unsigned-1
alien.accessors:alien-signed-1
alien.accessors:set-alien-unsigned-2
alien.accessors:alien-signed-2
alien.accessors:set-alien-signed-2
- alien.accessors:alien-cell
+ ! alien.accessors:alien-cell
alien.accessors:set-alien-cell
} [ t "intrinsic" set-word-prop ] each
alien.accessors:set-alien-float
alien.accessors:alien-double
alien.accessors:set-alien-double
- } [ t "intrinsic" set-word-prop ] each ;
+ } drop f [ t "intrinsic" set-word-prop ] each ;
: 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 ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: layouts namespaces kernel accessors sequences
classes.algebra compiler.tree.propagation.info
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
-compiler.cfg.utilities ;
+compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.slots
: value-tag ( info -- n ) class>> class-tag ; inline
+++ /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.splitting
compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.allocation
-: relevant-ranges ( new inactive -- new' inactive' )
- ! Slice off all ranges of 'inactive' that precede the start of 'new'
- [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
+: active-positions ( new assoc -- )
+ [ vreg>> active-intervals-for ] dip
+ '[ [ 0 ] dip reg>> _ add-use-position ] each ;
-: intersect-live-range ( range1 range2 -- n/f )
- 2dup [ from>> ] bi@ > [ swap ] when
- 2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
+: inactive-positions ( new assoc -- )
+ [ [ vreg>> inactive-intervals-for ] keep ] dip
+ '[
+ [ _ relevant-ranges intersect-live-ranges 1/0. or ] [ reg>> ] bi
+ _ add-use-position
+ ] each ;
-: intersect-live-ranges ( ranges1 ranges2 -- n )
- {
- { [ over empty? ] [ 2drop 1/0. ] }
- { [ dup empty? ] [ 2drop 1/0. ] }
- [
- 2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
- drop
- 2dup [ first from>> ] bi@ <
- [ [ rest-slice ] dip ] [ rest-slice ] if
- intersect-live-ranges
- ] if
- ]
- } cond ;
-
-: intersect-inactive ( new inactive -- n )
- relevant-ranges intersect-live-ranges ;
-
-: compute-free-pos ( new -- free-pos )
- dup vreg>>
- [ nip reg-class>> registers get at [ 1/0. ] H{ } map>assoc ]
- [ inactive-intervals-for [ [ reg>> swap ] keep intersect-inactive ] with H{ } map>assoc ]
- [ nip active-intervals-for [ reg>> 0 ] H{ } map>assoc ]
- 2tri 3array assoc-combine
+: 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 ;
IN: compiler.cfg.linear-scan.allocation.coalescing
: active-interval ( vreg -- live-interval )
dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
+: avoids-inactive-intervals? ( live-interval -- ? )
+ dup vreg>> inactive-intervals-for
+ [ intervals-intersect? not ] with all? ;
+
: coalesce? ( live-interval -- ? )
- [ start>> ] [ copy-from>> active-interval ] bi
- dup [ end>> = ] [ 2drop f ] if ;
+ {
+ [ copy-from>> active-interval ]
+ [ [ start>> ] [ copy-from>> active-interval end>> ] bi = ]
+ [ 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.renaming.functor
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
! This contains both active and inactive intervals; any interval
! such that start <= insn# <= end is in this set.
-SYMBOL: pending-intervals
+SYMBOL: pending-interval-heap
+SYMBOL: pending-interval-assoc
-: add-active ( live-interval -- )
- pending-intervals get push ;
+: add-pending ( live-interval -- )
+ [ dup end>> pending-interval-heap get heap-push ]
+ [ [ reg>> ] [ vreg>> ] bi pending-interval-assoc get set-at ]
+ bi ;
+
+: remove-pending ( live-interval -- )
+ vreg>> pending-interval-assoc get delete-at ;
! 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
-
-: spill-slots-for ( vreg -- assoc )
- reg-class>> spill-slots get at ;
+! Mapping from basic blocks to values which are live at the start
+SYMBOL: register-live-ins
-ERROR: already-spilled ;
+! Mapping from basic blocks to values which are live at the end
+SYMBOL: register-live-outs
-: record-spill ( live-interval -- )
- [ dup spill-to>> ] [ vreg>> spill-slots-for ] bi
- 2dup key? [ already-spilled ] [ set-at ] if ;
+: init-assignment ( live-intervals -- )
+ <min-heap> pending-interval-heap set
+ H{ } clone pending-interval-assoc set
+ <min-heap> unhandled-intervals set
+ H{ } clone register-live-ins set
+ H{ } clone register-live-outs set
+ init-unhandled ;
: insert-spill ( live-interval -- )
- {
- [ reg>> ]
- [ vreg>> reg-class>> ]
- [ spill-to>> ]
- [ end>> ]
- } cleave f swap \ _spill boa , ;
+ [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
: handle-spill ( live-interval -- )
- dup spill-to>> [ [ record-spill ] [ insert-spill ] bi ] [ drop ] if ;
+ dup spill-to>> [ insert-spill ] [ drop ] if ;
-: insert-copy ( live-interval -- )
- {
- [ split-next>> reg>> ]
- [ reg>> ]
- [ vreg>> reg-class>> ]
- [ end>> ]
- } cleave f swap \ _copy boa , ;
+: expire-interval ( live-interval -- )
+ [ remove-pending ] [ handle-spill ] bi ;
-: handle-copy ( live-interval -- )
- dup [ spill-to>> not ] [ split-next>> ] bi and
- [ insert-copy ] [ drop ] if ;
+: (expire-old-intervals) ( n heap -- )
+ dup heap-empty? [ 2drop ] [
+ 2dup heap-peek nip <= [ 2drop ] [
+ dup heap-pop drop expire-interval
+ (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-interval-heap get (expire-old-intervals) ;
: insert-reload ( live-interval -- )
- {
- [ reg>> ]
- [ vreg>> reg-class>> ]
- [ reload-from>> ]
- [ end>> ]
- } cleave f swap \ _reload boa , ;
+ [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
: 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
- #! are added to the active set.
- unhandled-intervals get dup heap-empty? [ 2drop ] [
- 2dup heap-peek drop start>> = [
- heap-pop drop
- [ add-active ] [ handle-reload ] bi
- activate-new-intervals
+: activate-interval ( live-interval -- )
+ [ add-pending ] [ handle-reload ] bi ;
+
+: (activate-new-intervals) ( n heap -- )
+ dup heap-empty? [ 2drop ] [
+ 2dup heap-peek nip = [
+ dup heap-pop drop activate-interval
+ (activate-new-intervals)
] [ 2drop ] if
] if ;
-GENERIC: assign-registers-in-insn ( insn -- )
-
-: register-mapping ( live-intervals -- alist )
- [ [ vreg>> ] [ reg>> ] bi ] { } map>assoc ;
+: activate-new-intervals ( n -- )
+ unhandled-intervals get (activate-new-intervals) ;
-: all-vregs ( insn -- vregs )
- [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
+: prepare-insn ( n -- )
+ [ expire-old-intervals ] [ activate-new-intervals ] bi ;
-: active-intervals ( insn -- intervals )
- insn#>> pending-intervals get [ covers? ] with filter ;
+GENERIC: assign-registers-in-insn ( insn -- )
-M: vreg-insn assign-registers-in-insn
- dup [ active-intervals ] [ all-vregs ] bi
- '[ vreg>> _ member? ] filter
- register-mapping
- >>regs drop ;
+: vreg>reg ( vreg -- reg ) pending-interval-assoc get at ;
-: compute-live-registers ( insn -- regs )
- [ active-intervals ] [ temp-vregs ] bi
- '[ vreg>> _ memq? not ] filter
- register-mapping ;
+RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
-: 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
+ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
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-values ( vregs -- assoc )
+ ! If a live vreg is not in active or inactive, then it must have been
+ ! spilled.
+ dup assoc-empty? [
+ pending-interval-assoc get
+ '[ _ ?at [ ] [ spill-slots get at <spill-slot> ] if ] assoc-map
+ ] unless ;
+
+: begin-block ( bb -- )
+ dup basic-block set
+ dup block-from activate-new-intervals
+ [ live-in compute-live-values ] keep
+ register-live-ins get set-at ;
+
+: end-block ( bb -- )
+ [ live-out 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 -- )
- [
+:: 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 ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences sets arrays math strings fry
-prettyprint compiler.cfg.linear-scan.live-intervals
-compiler.cfg.linear-scan.allocation ;
+namespaces prettyprint compiler.cfg.linear-scan.live-intervals
+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 )
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 ;
check-allocation? 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
+ spill-status
] 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?
-] 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 }
{ uses { 5 10 } }
{ ranges V{ T{ live-range f 5 10 } } }
}
- intersect-inactive
+ relevant-ranges intersect-live-ranges
] unit-test
-: test-bb ( insns n -- )
- [ <basic-block> swap >>number swap >>instructions ] keep set ;
+! 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
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 ;
-{ 1 2 } test-linear-scan-on-cfg
+! This test has a critical edge -- do we care about these?
+
+! [ { 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
+[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test
-USING: classes ;
-
-[ ] [
- 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
! 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)
+ 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#>> ;
M: vreg-insn compute-live-intervals*
dup insn#>>
live-intervals get
- [ [ defs-vregs ] 2dip '[ [ _ ] dip _ handle-output ] each ]
+ [ [ defs-vreg ] 2dip '[ [ _ ] dip _ handle-output ] when* ]
[ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ]
[ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
3tri ;
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 ( interval1 interval2 -- ranges1 ranges2 )
+ [ [ ranges>> ] bi@ ] [ nip start>> ] 2bi '[ to>> _ >= ] filter ;
+
+: intersect-live-range ( range1 range2 -- n/f )
+ 2dup [ from>> ] bi@ > [ swap ] when
+ 2dup [ to>> ] [ from>> ] bi* >= [ nip from>> ] [ 2drop f ] if ;
+
+: intersect-live-ranges ( ranges1 ranges2 -- n )
+ {
+ { [ over empty? ] [ 2drop f ] }
+ { [ dup empty? ] [ 2drop f ] }
+ [
+ 2dup [ first ] bi@ intersect-live-range dup [ 2nip ] [
+ drop
+ 2dup [ first from>> ] bi@ <
+ [ [ rest-slice ] dip ] [ rest-slice ] if
+ intersect-live-ranges
+ ] if
+ ]
+ } cond ;
+
+: intervals-intersect? ( interval1 interval2 -- ? )
+ relevant-ranges intersect-live-ranges >boolean ; inline
\ 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
IN: compiler.cfg.linear-scan.resolve.tests
-USING: compiler.cfg.linear-scan.resolve tools.test arrays kernel ;
+USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces
+compiler.cfg.instructions cpu.architecture make sequences
+compiler.cfg.linear-scan.allocation.state ;
-[ { 1 2 3 4 5 6 } ] [
- { 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array
+[
+ {
+ { { T{ spill-slot f 0 } int-regs } { 1 int-regs } }
+ }
+] [
+ [
+ 0 <spill-slot> 1 int-regs add-mapping
+ ] { } make
+] unit-test
+
+[
+ {
+ T{ _reload { dst 1 } { class int-regs } { n 0 } }
+ }
+] [
+ [
+ { T{ spill-slot f 0 } int-regs } { 1 int-regs } >insn
+ ] { } make
+] unit-test
+
+[
+ {
+ T{ _spill { src 1 } { class int-regs } { n 0 } }
+ }
+] [
+ [
+ { 1 int-regs } { T{ spill-slot f 0 } int-regs } >insn
+ ] { } make
+] unit-test
+
+[
+ {
+ T{ _copy { src 1 } { dst 2 } { class int-regs } }
+ }
+] [
+ [
+ { 1 int-regs } { 2 int-regs } >insn
+ ] { } make
+] unit-test
+
+H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
+H{ } clone spill-temps set
+
+[
+ t
+] [
+ { { { 0 int-regs } { 1 int-regs } } { { 1 int-regs } { 0 int-regs } } }
+ mapping-instructions {
+ {
+ T{ _spill { src 0 } { class int-regs } { n 10 } }
+ T{ _copy { dst 0 } { src 1 } { class int-regs } }
+ T{ _reload { dst 1 } { class int-regs } { n 10 } }
+ }
+ {
+ 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 } }
+ }
+ } member?
] 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
-combinators compiler.cfg.linear-scan.live-intervals
-compiler.cfg.liveness compiler.cfg.instructions ;
+USING: accessors arrays assocs combinators
+combinators.short-circuit fry kernel locals namespaces
+make math sequences hashtables
+compiler.cfg.rpo
+compiler.cfg.liveness
+compiler.cfg.utilities
+compiler.cfg.instructions
+compiler.cfg.parallel-copy
+compiler.cfg.linear-scan.assignment
+compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.resolve
-<<
+SYMBOL: spill-temps
-TUPLE: operation from to reg-class ;
+: spill-temp ( reg-class -- n )
+ spill-temps get [ next-spill-slot ] cache ;
-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 ;
-
->>
-
-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 ( from to -- )
- dup reload-from>> [
- over spill-to>> [ memory->memory ] [ register->memory ] if
- ] [
- over spill-to>> [ memory->register ] [ register->register ] if
- ] if ;
+: add-mapping ( from to reg-class -- )
+ '[ _ 2array ] bi@ 2array , ;
-: resolve-value-data-flow ( bb to vreg -- )
- live-intervals get at
- [ [ block-to ] dip child-interval-at ]
- [ [ block-from ] dip child-interval-at ]
- bi-curry bi* 2dup eq? [ 2drop ] [ add-mapping ] if ;
+:: resolve-value-data-flow ( bb to vreg -- )
+ vreg bb vreg-at-end
+ vreg to vreg-at-start
+ 2dup = [ 2drop ] [ vreg reg-class>> add-mapping ] if ;
: compute-mappings ( bb to -- mappings )
[
[ resolve-value-data-flow ] with with each
] { } make ;
-GENERIC: >insn ( operation -- )
-
-: >operation< ( operation -- from to reg-class )
- [ from>> ] [ to>> ] [ reg-class>> ] tri ; inline
-
-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 ;
+: memory->register ( from to -- )
+ swap [ first2 ] [ first n>> ] bi* _reload ;
-: mapping-instructions ( mappings -- insns )
- [ [ >insn ] each ] { } make ;
+: register->memory ( from to -- )
+ [ first2 ] [ first n>> ] bi* _spill ;
-: fork? ( from to -- ? )
- [ successors>> length 1 >= ]
- [ predecessors>> length 1 = ] bi* and ; inline
+: temp->register ( from to -- )
+ nip [ first ] [ second ] [ second spill-temp ] tri _reload ;
-: insert-position/fork ( from to -- before after )
- nip instructions>> [ >array ] [ dup delete-all ] bi swap ;
+: register->temp ( from to -- )
+ drop [ first2 ] [ second spill-temp ] bi _spill ;
-: join? ( from to -- ? )
- [ successors>> length 1 = ]
- [ predecessors>> length 1 >= ] bi* and ; inline
+: register->register ( from to -- )
+ swap [ first ] [ first2 ] bi* _copy ;
-: insert-position/join ( from to -- before after )
- drop instructions>> { } ;
+SYMBOL: temp
-: insert-position ( bb to -- before after )
+: >insn ( from to -- )
{
- { [ 2dup fork? ] [ insert-position/fork ] }
- { [ 2dup join? ] [ insert-position/join ] }
+ { [ over temp eq? ] [ temp->register ] }
+ { [ dup temp eq? ] [ register->temp ] }
+ { [ over first spill-slot? ] [ memory->register ] }
+ { [ dup first spill-slot? ] [ register->memory ] }
+ [ register->register ]
} cond ;
-: 3append-here ( seq2 seq1 seq3 -- )
- #! Mutate seq1
- swap '[ _ push-all ] bi@ ;
+: mapping-instructions ( alist -- insns )
+ [ swap ] H{ } assoc-map-as
+ [ temp [ swap >insn ] parallel-mapping ] { } make ;
-: 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 -- )
+ H{ } clone spill-temps set
+ [ resolve-block-data-flow ] each-basic-block ;
USING: kernel math accessors sequences namespaces make
combinators assocs arrays locals cpu.architecture
compiler.cfg
-compiler.cfg.rpo
-compiler.cfg.liveness
+compiler.cfg.comparisons
compiler.cfg.stack-frame
-compiler.cfg.instructions ;
+compiler.cfg.instructions
+compiler.cfg.utilities
+compiler.cfg.linearization.order ;
IN: compiler.cfg.linearization
! Convert CFG IR to machine IR.
GENERIC: linearize-insn ( basic-block insn -- )
: linearize-basic-block ( bb -- )
- [ number>> _label ]
+ [ block-number _label ]
[ dup instructions>> [ linearize-insn ] with each ]
bi ;
M: insn linearize-insn , drop ;
: useless-branch? ( basic-block successor -- ? )
- #! If our successor immediately follows us in RPO, then we
- #! 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 ;
+ ! If our successor immediately follows us in linearization
+ ! order then we don't need to branch.
+ [ block-number ] bi@ 1 - = ; inline
+
+: emit-branch ( bb successor -- )
+ 2dup useless-branch? [ 2drop ] [ nip block-number _branch ] if ;
M: ##branch linearize-insn
drop dup successors>> first emit-branch ;
-: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc )
- [ dup successors>> first2 ]
+: successors ( bb -- first second ) successors>> first2 ; inline
+
+: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
+ [ dup successors ]
[ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
-: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
+: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
[ (binary-conditional) ]
[ drop dup successors>> second useless-branch? ] 2bi
- [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
-
-: with-regs ( insn quot -- )
- over regs>> [ call ] dip building get last (>>regs) ; inline
+ [ [ swap block-number ] 3dip ] [ [ block-number ] 3dip negate-cc ] if ;
M: ##compare-branch linearize-insn
- [ binary-conditional _compare-branch ] with-regs emit-branch ;
+ binary-conditional _compare-branch emit-branch ;
M: ##compare-imm-branch linearize-insn
- [ binary-conditional _compare-imm-branch ] with-regs emit-branch ;
+ binary-conditional _compare-imm-branch emit-branch ;
M: ##compare-float-branch linearize-insn
- [ binary-conditional _compare-float-branch ] with-regs emit-branch ;
+ binary-conditional _compare-float-branch emit-branch ;
+
+: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
+ [ dup successors block-number ]
+ [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline
+
+M: ##fixnum-add linearize-insn
+ overflow-conditional _fixnum-add emit-branch ;
+
+M: ##fixnum-sub linearize-insn
+ overflow-conditional _fixnum-sub emit-branch ;
+
+M: ##fixnum-mul linearize-insn
+ overflow-conditional _fixnum-mul emit-branch ;
M: ##dispatch linearize-insn
swap
- [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ]
- [ successors>> [ number>> _dispatch-label ] each ]
+ [ [ src>> ] [ temp>> ] bi _dispatch ]
+ [ successors>> [ block-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>> ]
[
- [ temp1>> ]
- [ temp2>> ]
- [
- [ live-registers>> ] [ live-spill-slots>> ] bi
- [ compute-gc-roots ]
- [ count-gc-roots ]
- [ gc-roots-size ]
- 2tri
- ] tri
- _gc
- ] with-regs ;
+ live-values>>
+ [ compute-gc-roots ]
+ [ count-gc-roots ]
+ [ gc-roots-size ]
+ tri
+ ] tri
+ _gc ;
: linearize-basic-blocks ( cfg -- insns )
[
- [ [ linearize-basic-block ] each-basic-block ]
+ [ linearization-order [ linearize-basic-block ] each ]
[ spill-counts>> _spill-counts ]
bi
] { } make ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs deques dlists kernel make
+namespaces sequences combinators combinators.short-circuit
+fry math sets compiler.cfg.rpo compiler.cfg.utilities ;
+IN: compiler.cfg.linearization.order
+
+! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
+
+<PRIVATE
+
+SYMBOLS: work-list loop-heads visited numbers next-number ;
+
+: visited? ( bb -- ? ) visited get key? ;
+
+: add-to-work-list ( bb -- )
+ dup visited get key? [ drop ] [
+ work-list get push-back
+ ] if ;
+
+: (find-alternate-loop-head) ( bb -- bb' )
+ dup {
+ [ predecessor visited? not ]
+ [ predecessors>> length 1 = ]
+ [ predecessor successors>> length 1 = ]
+ [ [ number>> ] [ predecessor number>> ] bi > ]
+ } 1&& [ predecessor (find-alternate-loop-head) ] when ;
+
+: find-back-edge ( bb -- pred )
+ [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
+
+: find-alternate-loop-head ( bb -- bb' )
+ dup find-back-edge dup visited? [ drop ] [
+ nip (find-alternate-loop-head)
+ ] if ;
+
+: predecessors-ready? ( bb -- ? )
+ [ predecessors>> ] keep '[
+ _ 2dup back-edge?
+ [ 2drop t ] [ drop visited? ] if
+ ] all? ;
+
+: process-successor ( bb -- )
+ dup predecessors-ready? [
+ dup loop-entry? [ find-alternate-loop-head ] when
+ add-to-work-list
+ ] [ drop ] if ;
+
+: assign-number ( bb -- )
+ next-number [ get ] [ inc ] bi swap numbers get set-at ;
+
+: process-block ( bb -- )
+ {
+ [ , ]
+ [ assign-number ]
+ [ visited get conjoin ]
+ [ successors>> <reversed> [ process-successor ] each ]
+ } cleave ;
+
+PRIVATE>
+
+: linearization-order ( cfg -- bbs )
+ ! We call 'post-order drop' to ensure blocks receive their
+ ! RPO numbers.
+ <dlist> work-list set
+ H{ } clone visited set
+ H{ } clone numbers set
+ 0 next-number set
+ [ post-order drop ]
+ [ entry>> add-to-work-list ] bi
+ [ work-list get [ process-block ] slurp-deque ] { } make ;
+
+: block-number ( bb -- n ) numbers get at ;
+++ /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 vectors ;
+IN: compiler.cfg.liveness.tests
+
+: test-liveness ( -- )
+ cfg new 1 get >>entry
+ compute-predecessors
+ compute-live-sets ;
+
+! 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 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##replace f V int-regs 2 D 0 }
+ T{ ##branch }
+} 2 test-bb
+
+V{
+ T{ ##replace f V int-regs 3 D 0 }
+ T{ ##return }
+} 3 test-bb
+
+1 get 2 get 3 get V{ } 2sequence >>successors drop
+
+test-liveness
+
+[
+ 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
+
+! Tricky case; defs must be killed before uses
+
+V{
+ T{ ##peek f V int-regs 0 D 0 }
+ T{ ##branch }
+} 1 test-bb
+
+V{
+ T{ ##add-imm f V int-regs 0 V int-regs 0 10 }
+ T{ ##return }
+} 2 test-bb
+
+1 get 2 get 1vector >>successors drop
+
+test-liveness
+
+[ H{ { V int-regs 0 V int-regs 0 } } ] [ 2 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 ;
+GENERIC: insn-liveness ( live-set insn -- )
-! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
-! is in conrrespondence with a predecessor
-SYMBOL: phi-live-ins
+: kill-defs ( live-set insn -- live-set )
+ defs-vreg [ over delete-at ] when* ;
-: phi-live-in ( predecessor basic-block -- set )
- [ predecessors>> index ] keep phi-live-ins get at
- dup [ nth ] [ 2drop f ] if ;
+: gen-uses ( live-set insn -- live-set )
+ dup ##phi? [ drop ] [ uses-vregs [ over conjoin ] each ] if ;
-! Assoc mapping basic blocks to sets of vregs
-SYMBOL: live-outs
+: transfer-liveness ( live-set instructions -- live-set' )
+ [ clone ] [ <reversed> ] bi* [ [ kill-defs ] [ gen-uses ] bi ] each ;
-: live-out ( basic-block -- set ) live-outs get at ;
+: local-live-in ( instructions -- live-set )
+ [ H{ } ] dip transfer-liveness keys ;
-SYMBOL: work-list
+M: live-analysis transfer-set
+ drop instructions>> transfer-liveness ;
-: 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
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces deques accessors sets sequences assocs fry
+hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
+compiler.cfg.rpo compiler.cfg.liveness ;
+IN: compiler.cfg.liveness.ssa
+
+! TODO: merge with compiler.cfg.liveness
+
+! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
+! is in conrrespondence with a predecessor
+SYMBOL: phi-live-ins
+
+: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
+
+SYMBOL: work-list
+
+: add-to-work-list ( basic-blocks -- )
+ work-list get '[ _ push-front ] each ;
+
+: compute-live-in ( basic-block -- live-in )
+ [ live-out ] keep instructions>> transfer-liveness ;
+
+: compute-phi-live-in ( basic-block -- phi-live-in )
+ instructions>> [ ##phi? ] filter [ f ] [
+ H{ } clone [
+ '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each
+ ] keep
+ ] 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-ssa-live-sets ( 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 ;
+++ /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 ;
-IN: compiler.cfg.optimizer.tests
-
-! Miscellaneous tests
-
-: more? ( x -- ? ) ;
-
-: test-case-1 ( -- ? ) f ;
-
-: test-case-2 ( -- )
- test-case-1 [ test-case-2 ] [ ] if ; inline recursive
-
-{
- [ 1array ]
- [ 1 2 ? ]
- [ { array } declare [ ] map ]
- [ { array } declare dup 1 slot [ 1 slot ] when ]
- [ [ dup more? ] [ dup ] produce ]
- [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
- [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
- [
- { fixnum sbuf } declare 2dup 3 slot fixnum> [
- over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
- ] [ ] if
- ]
- [ [ 2 fixnum* ] when 3 ]
- [ [ 2 fixnum+ ] when 3 ]
- [ [ 2 fixnum- ] when 3 ]
- [ 10000 [ ] times ]
-} [
- [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
-] each
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors combinators namespaces
-compiler.cfg.predecessors
-compiler.cfg.useless-blocks
-compiler.cfg.height
-compiler.cfg.stack-analysis
+compiler.cfg.tco
+compiler.cfg.useless-conditionals
+compiler.cfg.branch-splitting
+compiler.cfg.block-joining
+compiler.cfg.ssa.construction
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
+compiler.cfg.copy-prop
compiler.cfg.dce
compiler.cfg.write-barrier
-compiler.cfg.liveness
+compiler.cfg.ssa.destruction
+compiler.cfg.empty-blocks
+compiler.cfg.predecessors
compiler.cfg.rpo
-compiler.cfg.phi-elimination
compiler.cfg.checker ;
IN: compiler.cfg.optimizer
] 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
- stack-analysis
- compute-liveness
+ compute-predecessors
+ split-branches
+ join-blocks
+ compute-predecessors
+ construct-ssa
alias-analysis
value-numbering
+ compute-predecessors
+ copy-propagation
eliminate-dead-code
eliminate-write-barriers
- eliminate-phis
+ destruct-ssa
+ delete-empty-blocks
?check
] with-scope ;
--- /dev/null
+USING: compiler.cfg.parallel-copy tools.test make arrays
+compiler.cfg.registers namespaces compiler.cfg.instructions
+cpu.architecture ;
+IN: compiler.cfg.parallel-copy.tests
+
+SYMBOL: temp
+
+: test-parallel-copy ( mapping -- seq )
+ 3 vreg-counter set-global
+ [ parallel-copy ] { } make ;
+
+[
+ {
+ T{ ##copy f V int-regs 4 V int-regs 2 }
+ T{ ##copy f V int-regs 2 V int-regs 1 }
+ T{ ##copy f V int-regs 1 V int-regs 4 }
+ }
+] [
+ H{
+ { V int-regs 1 V int-regs 2 }
+ { V int-regs 2 V int-regs 1 }
+ } test-parallel-copy
+] unit-test
+
+[
+ {
+ T{ ##copy f V int-regs 1 V int-regs 2 }
+ T{ ##copy f V int-regs 3 V int-regs 4 }
+ }
+] [
+ H{
+ { V int-regs 1 V int-regs 2 }
+ { V int-regs 3 V int-regs 4 }
+ } test-parallel-copy
+] unit-test
+
+[
+ {
+ T{ ##copy f V int-regs 1 V int-regs 3 }
+ T{ ##copy f V int-regs 2 V int-regs 1 }
+ }
+] [
+ H{
+ { V int-regs 1 V int-regs 3 }
+ { V int-regs 2 V int-regs 3 }
+ } test-parallel-copy
+] unit-test
+
+[
+ {
+ T{ ##copy f V int-regs 4 V int-regs 3 }
+ T{ ##copy f V int-regs 3 V int-regs 2 }
+ T{ ##copy f V int-regs 2 V int-regs 1 }
+ T{ ##copy f V int-regs 1 V int-regs 4 }
+ }
+] [
+ {
+ { V int-regs 2 V int-regs 1 }
+ { V int-regs 3 V int-regs 2 }
+ { V int-regs 1 V int-regs 3 }
+ { V int-regs 4 V int-regs 3 }
+ } test-parallel-copy
+] 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: assocs compiler.cfg.hats compiler.cfg.instructions
+deques dlists fry kernel locals namespaces sequences
+hashtables ;
+IN: compiler.cfg.parallel-copy
+
+! Revisiting Out-of-SSA Translation for Correctness, Code Quality, and Efficiency
+! http://hal.archives-ouvertes.fr/docs/00/34/99/25/PDF/OutSSA-RR.pdf,
+! Algorithm 1
+
+<PRIVATE
+
+SYMBOLS: temp locs preds to-do ready ;
+
+: init-to-do ( bs -- )
+ to-do get push-all-back ;
+
+: init-ready ( bs -- )
+ locs get '[ _ key? not ] filter ready get push-all-front ;
+
+: init ( mapping temp -- )
+ temp set
+ <dlist> to-do set
+ <dlist> ready set
+ [ preds set ]
+ [ [ nip dup ] H{ } assoc-map-as locs set ]
+ [ keys [ init-to-do ] [ init-ready ] bi ] tri ;
+
+:: process-ready ( b quot -- )
+ b preds get at :> a
+ a locs get at :> c
+ b c quot call
+ b a locs get set-at
+ a c = a preds get at and [ a ready get push-front ] when ; inline
+
+:: process-to-do ( b quot -- )
+ ! Note that we check if b = loc(b), not b = loc(pred(b)) as the
+ ! paper suggests. Confirmed by one of the authors at
+ ! http://www.reddit.com/comments/93253/some_lecture_notes_on_ssa_form/c0bco4f
+ b locs get at b = [
+ temp get b quot call
+ temp get b locs get set-at
+ b ready get push-front
+ ] when ; inline
+
+PRIVATE>
+
+:: parallel-mapping ( mapping temp quot -- )
+ [
+ mapping temp init
+ to-do get [
+ ready get [
+ quot process-ready
+ ] slurp-deque
+ quot process-to-do
+ ] slurp-deque
+ ] with-scope ; inline
+
+: parallel-copy ( mapping -- ) i [ ##copy ] parallel-mapping ;
\ No newline at end of file
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors compiler.cfg compiler.cfg.instructions
-compiler.cfg.rpo fry kernel sequences ;
-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-step ( bb -- )
- dup [
- [ ##phi? ] partition
- [ [ eliminate-phi ] with each ] dip
- ] change-instructions drop ;
-
-: eliminate-phis ( cfg -- cfg' )
- dup [ eliminate-phi-step ] each-basic-block ;
\ No newline at end of file
! 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: functors assocs kernel accessors compiler.cfg.instructions
+lexer parser ;
+IN: compiler.cfg.renaming.functor
+
+FUNCTOR: define-renaming ( NAME DEF-QUOT USE-QUOT TEMP-QUOT -- )
+
+rename-insn-defs DEFINES ${NAME}-insn-defs
+rename-insn-uses DEFINES ${NAME}-insn-uses
+rename-insn-temps DEFINES ${NAME}-insn-temps
+
+WHERE
+
+GENERIC: rename-insn-defs ( insn -- )
+
+M: ##flushable rename-insn-defs
+ DEF-QUOT change-dst
+ drop ;
+
+M: ##fixnum-overflow rename-insn-defs
+ DEF-QUOT change-dst
+ drop ;
+
+M: _fixnum-overflow rename-insn-defs
+ DEF-QUOT change-dst
+ drop ;
+
+M: insn rename-insn-defs drop ;
+
+GENERIC: rename-insn-uses ( insn -- )
+
+M: ##effect rename-insn-uses
+ USE-QUOT change-src
+ drop ;
+
+M: ##unary rename-insn-uses
+ USE-QUOT change-src
+ drop ;
+
+M: ##binary rename-insn-uses
+ USE-QUOT change-src1
+ USE-QUOT change-src2
+ drop ;
+
+M: ##binary-imm rename-insn-uses
+ USE-QUOT change-src1
+ drop ;
+
+M: ##slot rename-insn-uses
+ USE-QUOT change-obj
+ USE-QUOT change-slot
+ drop ;
+
+M: ##slot-imm rename-insn-uses
+ USE-QUOT change-obj
+ drop ;
+
+M: ##set-slot rename-insn-uses
+ dup call-next-method
+ USE-QUOT change-obj
+ USE-QUOT change-slot
+ drop ;
+
+M: ##string-nth rename-insn-uses
+ USE-QUOT change-obj
+ USE-QUOT change-index
+ drop ;
+
+M: ##set-string-nth-fast rename-insn-uses
+ dup call-next-method
+ USE-QUOT change-obj
+ USE-QUOT change-index
+ drop ;
+
+M: ##set-slot-imm rename-insn-uses
+ dup call-next-method
+ USE-QUOT change-obj
+ drop ;
+
+M: ##alien-getter rename-insn-uses
+ dup call-next-method
+ USE-QUOT change-src
+ drop ;
+
+M: ##alien-setter rename-insn-uses
+ dup call-next-method
+ USE-QUOT change-value
+ drop ;
+
+M: ##conditional-branch rename-insn-uses
+ USE-QUOT change-src1
+ USE-QUOT change-src2
+ drop ;
+
+M: ##compare-imm-branch rename-insn-uses
+ USE-QUOT change-src1
+ drop ;
+
+M: ##dispatch rename-insn-uses
+ USE-QUOT change-src
+ drop ;
+
+M: ##fixnum-overflow rename-insn-uses
+ USE-QUOT change-src1
+ USE-QUOT change-src2
+ drop ;
+
+M: ##phi rename-insn-uses
+ [ USE-QUOT assoc-map ] change-inputs
+ drop ;
+
+M: insn rename-insn-uses drop ;
+
+GENERIC: rename-insn-temps ( insn -- )
+
+M: ##write-barrier rename-insn-temps
+ TEMP-QUOT change-card#
+ TEMP-QUOT change-table
+ drop ;
+
+M: ##unary/temp rename-insn-temps
+ TEMP-QUOT change-temp drop ;
+
+M: ##allot rename-insn-temps
+ TEMP-QUOT change-temp drop ;
+
+M: ##dispatch rename-insn-temps
+ TEMP-QUOT change-temp drop ;
+
+M: ##slot rename-insn-temps
+ TEMP-QUOT change-temp drop ;
+
+M: ##set-slot rename-insn-temps
+ TEMP-QUOT change-temp drop ;
+
+M: ##string-nth rename-insn-temps
+ TEMP-QUOT change-temp drop ;
+
+M: ##set-string-nth-fast rename-insn-temps
+ TEMP-QUOT change-temp drop ;
+
+M: ##compare rename-insn-temps
+ TEMP-QUOT change-temp drop ;
+
+M: ##compare-imm rename-insn-temps
+ TEMP-QUOT change-temp drop ;
+
+M: ##compare-float rename-insn-temps
+ TEMP-QUOT change-temp drop ;
+
+M: ##gc rename-insn-temps
+ TEMP-QUOT change-temp1
+ TEMP-QUOT change-temp2
+ drop ;
+
+M: _dispatch rename-insn-temps
+ TEMP-QUOT change-temp drop ;
+
+M: insn rename-insn-temps drop ;
+
+;FUNCTOR
+
+SYNTAX: RENAMING: scan scan-object scan-object scan-object define-renaming ;
\ 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 kernel namespaces sequences
+compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.renaming.functor ;
+IN: compiler.cfg.renaming
+
+SYMBOL: renamings
+
+: rename-value ( vreg -- vreg' )
+ renamings get ?at drop ;
+
+: fresh-value ( vreg -- vreg' )
+ reg-class>> next-vreg ;
+
+RENAMING: rename [ rename-value ] [ rename-value ] [ fresh-value ]
: 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.construction assocs
+compiler.cfg.registers cpu.architecture kernel namespaces sequences
+tools.test vectors ;
+IN: compiler.cfg.ssa.construction.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.liveness
+compiler.cfg.registers
+compiler.cfg.dominance
+compiler.cfg.instructions
+compiler.cfg.renaming.functor
+compiler.cfg.ssa.construction.tdmsc ;
+IN: compiler.cfg.ssa.construction
+
+! SSA construction. Predecessors must be computed first.
+
+! The phi placement algorithm is implemented in
+! compiler.cfg.ssa.construction.tdmsc.
+
+! The renaming algorithm is based on "Practical Improvements to
+! the Construction and Destruction of Static Single Assignment Form",
+! however we construct pruned SSA, not semi-pruned SSA.
+
+! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.49.9683
+
+<PRIVATE
+
+! Maps vregs to sets of basic blocks
+SYMBOL: defs
+
+! Set of vregs defined in more than one basic block
+SYMBOL: defs-multi
+
+: compute-insn-defs ( bb insn -- )
+ defs-vreg dup [
+ defs get [ conjoin-at ] [ drop ] [ at assoc-size 1 > ] 2tri
+ [ defs-multi get conjoin ] [ drop ] if
+ ] [ 2drop ] if ;
+
+: compute-defs ( cfg -- )
+ H{ } clone defs set
+ H{ } clone defs-multi set
+ [
+ dup instructions>> [
+ compute-insn-defs
+ ] with each
+ ] each-basic-block ;
+
+! Maps basic blocks to sequences of vregs
+SYMBOL: inserting-phi-nodes
+
+: 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 [ insert-phi-node-later ] with merge-set-each ;
+
+: compute-phi-nodes ( -- )
+ H{ } clone inserting-phi-nodes set
+ defs-multi get defs get '[ _ at 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 pushed ;
+
+: init-renaming ( -- )
+ H{ } clone stacks set ;
+
+: gen-name ( vreg -- vreg' )
+ [ reg-class>> next-vreg dup ] keep
+ dup pushed get 2dup key?
+ [ 2drop stacks get at set-last ]
+ [ conjoin stacks get push-at ]
+ if ;
+
+: top-name ( vreg -- vreg' )
+ stacks get at last ;
+
+RENAMING: ssa-rename [ gen-name ] [ top-name ] [ ]
+
+GENERIC: rename-insn ( insn -- )
+
+M: insn rename-insn
+ [ ssa-rename-insn-uses ]
+ [ ssa-rename-insn-defs ]
+ bi ;
+
+M: ##phi rename-insn
+ ssa-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 ( -- )
+ pushed get stacks get '[ drop _ at pop* ] assoc-each ;
+
+: rename-in-block ( bb -- )
+ H{ } clone pushed set
+ [ rename-insns ]
+ [ rename-successors-phis ]
+ [
+ pushed get
+ [ dom-children [ rename-in-block ] each ] dip
+ pushed set
+ ] tri
+ pop-stacks ;
+
+: rename ( cfg -- )
+ init-renaming
+ entry>> rename-in-block ;
+
+PRIVATE>
+
+: construct-ssa ( cfg -- cfg' )
+ {
+ [ ]
+ [ compute-live-sets ]
+ [ compute-dominance ]
+ [ compute-merge-sets ]
+ [ compute-defs compute-phi-nodes insert-phi-nodes ]
+ [ rename ]
+ } cleave ;
\ No newline at end of file
--- /dev/null
+USING: accessors arrays compiler.cfg compiler.cfg.debugger
+compiler.cfg.dominance compiler.cfg.predecessors
+compiler.cfg.ssa.construction.tdmsc kernel namespaces sequences
+tools.test vectors sets ;
+IN: compiler.cfg.ssa.construction.tdmsc.tests
+
+: test-tdmsc ( -- )
+ cfg new 0 get >>entry
+ compute-predecessors
+ dup compute-dominance
+ compute-merge-sets ;
+
+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-tdmsc ] unit-test
+
+[ V{ 4 } ] [ 1 get 1array merge-set [ number>> ] map ] unit-test
+[ V{ 4 } ] [ 2 get 1array merge-set [ number>> ] map ] unit-test
+[ V{ } ] [ 0 get 1array merge-set ] unit-test
+[ V{ } ] [ 4 get 1array merge-set ] 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-tdmsc ] unit-test
+
+[ t ] [
+ 2 get 3 get 2array merge-set
+ 4 get 6 get 2array set=
+] 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
+V{ } 7 test-bb
+
+0 get 1 get 1vector >>successors drop
+1 get 2 get 1vector >>successors drop
+2 get 3 get 6 get V{ } 2sequence >>successors drop
+3 get 4 get 1vector >>successors drop
+6 get 7 get 1vector >>successors drop
+4 get 5 get 1vector >>successors drop
+5 get 2 get 1vector >>successors drop
+
+[ ] [ test-tdmsc ] unit-test
+
+[ V{ 2 } ] [ { 2 3 4 5 } [ get ] map merge-set [ number>> ] map ] unit-test
+[ V{ } ] [ { 0 1 6 7 } [ get ] map merge-set ] 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 arrays assocs bit-arrays bit-sets fry
+hashtables hints kernel locals math namespaces sequences sets
+compiler.cfg compiler.cfg.dominance compiler.cfg.rpo ;
+IN: compiler.cfg.ssa.construction.tdmsc
+
+! TDMSC-I algorithm from "A Practical and Fast Iterative Algorithm for
+! Phi-Function Computation Using DJ Graphs"
+
+! http://portal.acm.org/citation.cfm?id=1065887.1065890
+
+<PRIVATE
+
+SYMBOLS: visited merge-sets levels again? ;
+
+: init-merge-sets ( cfg -- )
+ post-order dup length '[ _ <bit-array> ] H{ } map>assoc merge-sets set ;
+
+: compute-levels ( cfg -- )
+ 0 over entry>> associate [
+ '[
+ _ [ [ dom-parent ] dip at 1 + ] 2keep set-at
+ ] each-basic-block
+ ] keep levels set ;
+
+: j-edge? ( from to -- ? )
+ 2dup eq? [ 2drop f ] [ dominates? not ] if ;
+
+: level ( bb -- n ) levels get at ; inline
+
+: set-bit ( bit-array n -- )
+ [ t ] 2dip swap set-nth ;
+
+: update-merge-set ( tmp to -- )
+ [ merge-sets get ] dip
+ '[
+ _
+ [ merge-sets get at bit-set-union ]
+ [ dupd number>> set-bit ]
+ bi
+ ] change-at ;
+
+:: walk ( tmp to lnode -- lnode )
+ tmp level to level >= [
+ tmp to update-merge-set
+ tmp dom-parent to tmp walk
+ ] [ lnode ] if ;
+
+: each-incoming-j-edge ( bb quot: ( from to -- ) -- )
+ [ [ predecessors>> ] keep ] dip
+ '[ _ 2dup j-edge? _ [ 2drop ] if ] each ; inline
+
+: visited? ( pair -- ? ) visited get key? ;
+
+: consistent? ( snode lnode -- ? )
+ [ merge-sets get at ] bi@ swap bit-set-subset? ;
+
+: (process-edge) ( from to -- )
+ f walk [
+ 2dup 2array visited? [
+ consistent? [ again? on ] unless
+ ] [ 2drop ] if
+ ] each-incoming-j-edge ;
+
+: process-edge ( from to -- )
+ 2dup 2array dup visited? [ 3drop ] [
+ visited get conjoin
+ (process-edge)
+ ] if ;
+
+: process-block ( bb -- )
+ [ process-edge ] each-incoming-j-edge ;
+
+: compute-merge-set-step ( bfo -- )
+ visited get clear-assoc
+ [ process-block ] each ;
+
+: compute-merge-set-loop ( cfg -- )
+ breadth-first-order
+ '[ again? off _ compute-merge-set-step again? get ]
+ loop ;
+
+: (merge-set) ( bbs -- flags rpo )
+ merge-sets get '[ _ at ] [ bit-set-union ] map-reduce
+ cfg get reverse-post-order ; inline
+
+: filter-by ( flags seq -- seq' )
+ [ drop ] pusher [ 2each ] dip ;
+
+HINTS: filter-by { bit-array object } ;
+
+PRIVATE>
+
+: compute-merge-sets ( cfg -- )
+ dup cfg set
+ H{ } clone visited set
+ [ compute-levels ]
+ [ init-merge-sets ]
+ [ compute-merge-set-loop ]
+ tri ;
+
+: merge-set-each ( bbs quot: ( bb -- ) -- )
+ [ (merge-set) ] dip '[
+ swap _ [ drop ] if
+ ] 2each ; inline
+
+: merge-set ( bbs -- bbs' )
+ (merge-set) filter-by ;
\ 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 hashtables fry kernel make namespaces
+sequences compiler.cfg.ssa.destruction.state compiler.cfg.parallel-copy ;
+IN: compiler.cfg.ssa.destruction.copies
+
+ERROR: bad-copy ;
+
+: compute-copies ( assoc -- assoc' )
+ dup assoc-size <hashtable> [
+ '[
+ [
+ 2dup eq? [ 2drop ] [
+ _ 2dup key?
+ [ bad-copy ] [ set-at ] if
+ ] if
+ ] with each
+ ] assoc-each
+ ] keep ;
+
+: insert-copies ( -- )
+ waiting get [
+ [ instructions>> building ] dip '[
+ building get pop
+ _ compute-copies parallel-copy
+ ,
+ ] with-variable
+ ] assoc-each ;
\ 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 fry kernel locals math math.order
+sequences namespaces sets
+compiler.cfg.rpo
+compiler.cfg.def-use
+compiler.cfg.utilities
+compiler.cfg.dominance
+compiler.cfg.instructions
+compiler.cfg.liveness.ssa
+compiler.cfg.critical-edges
+compiler.cfg.ssa.destruction.state
+compiler.cfg.ssa.destruction.forest
+compiler.cfg.ssa.destruction.copies
+compiler.cfg.ssa.destruction.renaming
+compiler.cfg.ssa.destruction.live-ranges
+compiler.cfg.ssa.destruction.process-blocks ;
+IN: compiler.cfg.ssa.destruction
+
+! Based on "Fast Copy Coalescing and Live-Range Identification"
+! http://www.cs.ucsd.edu/classes/sp02/cse231/kenpldi.pdf
+
+! Dominance, liveness and def-use need to be computed
+
+: process-blocks ( cfg -- )
+ [ [ process-block ] if-has-phis ] each-basic-block ;
+
+SYMBOL: seen
+
+:: visit-renaming ( dst assoc src bb -- )
+ src seen get key? [
+ src dst bb waiting-for push-at
+ src assoc delete-at
+ ] [ src seen get conjoin ] if ;
+
+:: break-interferences ( -- )
+ V{ } clone seen set
+ renaming-sets get [| dst assoc |
+ assoc [| src bb |
+ dst assoc src bb visit-renaming
+ ] assoc-each
+ ] assoc-each ;
+
+: remove-phis-from-block ( bb -- )
+ instructions>> [ ##phi? not ] filter-here ;
+
+: remove-phis ( cfg -- )
+ [ [ remove-phis-from-block ] if-has-phis ] each-basic-block ;
+
+: destruct-ssa ( cfg -- cfg' )
+ dup cfg-has-phis? [
+ init-coalescing
+ compute-ssa-live-sets
+ dup split-critical-edges
+ dup compute-def-use
+ dup compute-dominance
+ dup compute-live-ranges
+ dup process-blocks
+ break-interferences
+ dup perform-renaming
+ insert-copies
+ dup remove-phis
+ ] when ;
\ No newline at end of file
--- /dev/null
+USING: accessors compiler.cfg compiler.cfg.ssa.destruction.forest
+compiler.cfg.debugger compiler.cfg.dominance compiler.cfg.instructions
+compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.def-use
+cpu.architecture kernel namespaces sequences tools.test vectors sorting
+math.order ;
+IN: compiler.cfg.ssa.destruction.forest.tests
+
+V{ T{ ##peek f V int-regs 0 D 0 } } clone 0 test-bb
+V{ T{ ##peek f V int-regs 1 D 0 } } clone 1 test-bb
+V{ T{ ##peek f V int-regs 2 D 0 } } clone 2 test-bb
+V{ T{ ##peek f V int-regs 3 D 0 } } clone 3 test-bb
+V{ T{ ##peek f V int-regs 4 D 0 } } clone 4 test-bb
+V{ T{ ##peek f V int-regs 5 D 0 } } clone 5 test-bb
+V{ T{ ##peek f V int-regs 6 D 0 } } clone 6 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+2 get 3 get 4 get V{ } 2sequence >>successors drop
+3 get 5 get 1vector >>successors drop
+4 get 5 get 1vector >>successors drop
+1 get 6 get 1vector >>successors drop
+5 get 6 get 1vector >>successors drop
+
+: clean-up-forest ( forest -- forest' )
+ [ [ vreg>> n>> ] compare ] sort
+ [
+ [ clean-up-forest ] change-children
+ [ number>> ] change-bb
+ ] V{ } map-as ;
+
+: test-dom-forest ( vregs -- forest )
+ cfg new 0 get >>entry
+ compute-predecessors
+ dup compute-dominance
+ compute-def-use
+ compute-dom-forest
+ clean-up-forest ;
+
+[ V{ } ] [ { } test-dom-forest ] unit-test
+
+[ V{ T{ dom-forest-node f V int-regs 0 0 V{ } } } ]
+[ { V int-regs 0 } test-dom-forest ]
+unit-test
+
+[
+ V{
+ T{ dom-forest-node
+ f
+ V int-regs 0
+ 0
+ V{ T{ dom-forest-node f V int-regs 1 1 V{ } } }
+ }
+ }
+]
+[ { V int-regs 0 V int-regs 1 } test-dom-forest ]
+unit-test
+
+[
+ V{
+ T{ dom-forest-node
+ f
+ V int-regs 1
+ 1
+ V{ }
+ }
+ T{ dom-forest-node
+ f
+ V int-regs 2
+ 2
+ V{
+ T{ dom-forest-node f V int-regs 3 3 V{ } }
+ T{ dom-forest-node f V int-regs 4 4 V{ } }
+ T{ dom-forest-node f V int-regs 5 5 V{ } }
+ }
+ }
+ T{ dom-forest-node
+ f
+ V int-regs 6
+ 6
+ V{ }
+ }
+ }
+]
+[
+ { V int-regs 1 V int-regs 6 V int-regs 2 V int-regs 3 V int-regs 4 V int-regs 5 }
+ test-dom-forest
+] 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 assocs fry kernel math math.order
+namespaces sequences sorting vectors compiler.cfg.def-use
+compiler.cfg.dominance compiler.cfg.registers ;
+IN: compiler.cfg.ssa.destruction.forest
+
+TUPLE: dom-forest-node vreg bb children ;
+
+<PRIVATE
+
+: sort-vregs-by-bb ( vregs -- alist )
+ defs get
+ '[ dup _ at ] { } map>assoc
+ [ [ second pre-of ] compare ] sort ;
+
+: <dom-forest-node> ( vreg bb parent -- node )
+ [ V{ } clone dom-forest-node boa dup ] dip children>> push ;
+
+: <virtual-root> ( -- node )
+ f f V{ } clone dom-forest-node boa ;
+
+: find-parent ( pre stack -- parent )
+ 2dup last vreg>> def-of maxpre-of > [
+ dup pop* find-parent
+ ] [ nip last ] if ;
+
+: (compute-dom-forest) ( vreg bb stack -- )
+ [ dup pre-of ] dip [ find-parent <dom-forest-node> ] keep push ;
+
+PRIVATE>
+
+: compute-dom-forest ( vregs -- forest )
+ <virtual-root> [
+ 1vector
+ [ sort-vregs-by-bb ] dip
+ '[ _ (compute-dom-forest) ] assoc-each
+ ] keep children>> ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators combinators.short-circuit
+kernel math namespaces sequences locals compiler.cfg.def-use
+compiler.cfg.dominance compiler.cfg.ssa.destruction.live-ranges ;
+IN: compiler.cfg.ssa.destruction.interference
+
+<PRIVATE
+
+: kill-after-def? ( vreg1 vreg2 bb -- ? )
+ ! If first register is used after second one is defined, they interfere.
+ ! If they are used in the same instruction, no interference. If the
+ ! instruction is a def-is-use-insn, then there will be a use at +1
+ ! (instructions are 2 apart) and so outputs will interfere with
+ ! inputs.
+ [ kill-index ] [ def-index ] bi-curry bi* > ;
+
+: interferes-same-block? ( vreg1 vreg2 bb1 bb2 -- ? )
+ ! If both are defined in the same basic block, they interfere if their
+ ! local live ranges intersect.
+ drop
+ { [ kill-after-def? ] [ swapd kill-after-def? ] } 3|| ;
+
+: interferes-first-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
+ ! If vreg1 dominates vreg2, then they interfere if vreg2's definition
+ ! occurs before vreg1 is killed.
+ nip
+ kill-after-def? ;
+
+: interferes-second-dominates? ( vreg1 vreg2 bb1 bb2 -- ? )
+ ! If vreg2 dominates vreg1, then they interfere if vreg1's definition
+ ! occurs before vreg2 is killed.
+ drop
+ swapd kill-after-def? ;
+
+PRIVATE>
+
+: interferes? ( vreg1 vreg2 -- ? )
+ 2dup [ def-of ] bi@ {
+ { [ 2dup eq? ] [ interferes-same-block? ] }
+ { [ 2dup dominates? ] [ interferes-first-dominates? ] }
+ { [ 2dup swap dominates? ] [ interferes-second-dominates? ] }
+ [ 2drop 2drop f ]
+ } cond ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs fry kernel namespaces sequences math
+arrays compiler.cfg.def-use compiler.cfg.instructions
+compiler.cfg.liveness compiler.cfg.rpo ;
+IN: compiler.cfg.ssa.destruction.live-ranges
+
+! Live ranges for interference testing
+
+<PRIVATE
+
+SYMBOLS: local-def-indices local-kill-indices ;
+
+: record-def ( n vregs -- )
+ dup [ local-def-indices get set-at ] [ 2drop ] if ;
+
+: record-uses ( n vregs -- )
+ local-kill-indices get '[ _ set-at ] with each ;
+
+: visit-insn ( insn n -- )
+ ! Instructions are numbered 2 apart. If the instruction requires
+ ! that outputs are in different registers than the inputs, then
+ ! a use will be registered for every output immediately after
+ ! this instruction and before the next one, ensuring that outputs
+ ! interfere with inputs.
+ 2 *
+ [ swap defs-vreg record-def ]
+ [ swap uses-vregs record-uses ]
+ [ over def-is-use-insn? [ 1 + swap defs-vreg 1array record-uses ] [ 2drop ] if ]
+ 2tri ;
+
+SYMBOLS: def-indices kill-indices ;
+
+: compute-local-live-ranges ( bb -- )
+ H{ } clone local-def-indices set
+ H{ } clone local-kill-indices set
+ [ instructions>> [ visit-insn ] each-index ]
+ [ [ local-def-indices get ] dip def-indices get set-at ]
+ [ [ local-kill-indices get ] dip kill-indices get set-at ]
+ tri ;
+
+PRIVATE>
+
+: compute-live-ranges ( cfg -- )
+ H{ } clone def-indices set
+ H{ } clone kill-indices set
+ [ compute-local-live-ranges ] each-basic-block ;
+
+: def-index ( vreg bb -- n )
+ def-indices get at at ;
+
+ERROR: bad-kill-index vreg bb ;
+
+: kill-index ( vreg bb -- n )
+ 2dup live-out key? [ 2drop 1/0. ] [
+ 2dup kill-indices get at at* [ 2nip ] [
+ drop 2dup live-in key?
+ [ bad-kill-index ] [ 2drop -1/0. ] if
+ ] if
+ ] if ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs fry kernel locals math math.order arrays
+namespaces sequences sorting sets combinators combinators.short-circuit make
+compiler.cfg.def-use
+compiler.cfg.instructions
+compiler.cfg.liveness
+compiler.cfg.dominance
+compiler.cfg.ssa.destruction.state
+compiler.cfg.ssa.destruction.forest
+compiler.cfg.ssa.destruction.interference ;
+IN: compiler.cfg.ssa.destruction.process-blocks
+
+! phi-union maps a vreg to the predecessor block
+! that carries it to the phi node's block
+
+! unioned-blocks is a set of bb's which defined
+! the source vregs above
+SYMBOLS: phi-union unioned-blocks ;
+
+:: operand-live-into-phi-node's-block? ( bb src dst -- ? )
+ src bb live-in key? ;
+
+:: phi-node-is-live-out-of-operand's-block? ( bb src dst -- ? )
+ dst src def-of live-out key? ;
+
+:: operand-is-phi-node-and-live-into-operand's-block? ( bb src dst -- ? )
+ { [ src insn-of ##phi? ] [ src src def-of live-in key? ] } 0&& ;
+
+:: operand-being-renamed? ( bb src dst -- ? )
+ src processed-names get key? ;
+
+:: two-operands-in-same-block? ( bb src dst -- ? )
+ src def-of unioned-blocks get key? ;
+
+: trivial-interference? ( bb src dst -- ? )
+ {
+ [ operand-live-into-phi-node's-block? ]
+ [ phi-node-is-live-out-of-operand's-block? ]
+ [ operand-is-phi-node-and-live-into-operand's-block? ]
+ [ operand-being-renamed? ]
+ [ two-operands-in-same-block? ]
+ } 3|| ;
+
+: don't-coalesce ( bb src dst -- )
+ 2nip processed-name ;
+
+:: trivial-interference ( bb src dst -- )
+ dst src bb waiting-for push-at
+ src used-by-another get push ;
+
+:: add-to-renaming-set ( bb src dst -- )
+ bb src phi-union get set-at
+ src def-of unioned-blocks get conjoin ;
+
+: process-phi-operand ( bb src dst -- )
+ {
+ { [ 2dup eq? ] [ don't-coalesce ] }
+ { [ 3dup trivial-interference? ] [ trivial-interference ] }
+ [ add-to-renaming-set ]
+ } cond ;
+
+: node-is-live-in-of-child? ( node child -- ? )
+ [ vreg>> ] [ bb>> live-in ] bi* key? ;
+
+: node-is-live-out-of-child? ( node child -- ? )
+ [ vreg>> ] [ bb>> live-out ] bi* key? ;
+
+:: insert-copy ( bb src dst -- )
+ bb src dst trivial-interference
+ src phi-union get delete-at ;
+
+:: insert-copy-for-parent ( bb src node dst -- )
+ src node vreg>> eq? [ bb src dst insert-copy ] when ;
+
+: insert-copies-for-parent ( ##phi node child -- )
+ drop
+ [ [ inputs>> ] [ dst>> ] bi ] dip
+ '[ _ _ insert-copy-for-parent ] assoc-each ;
+
+: defined-in-same-block? ( node child -- ? ) [ bb>> ] bi@ eq? ;
+
+: add-interference ( ##phi node child -- )
+ [ vreg>> ] bi@ 2array , drop ;
+
+: process-df-child ( ##phi node child -- )
+ {
+ { [ 2dup node-is-live-out-of-child? ] [ insert-copies-for-parent ] }
+ { [ 2dup node-is-live-in-of-child? ] [ add-interference ] }
+ { [ 2dup defined-in-same-block? ] [ add-interference ] }
+ [ 3drop ]
+ } cond ;
+
+: process-df-node ( ##phi node -- )
+ dup children>>
+ [ [ process-df-child ] with with each ]
+ [ nip [ process-df-node ] with each ]
+ 3bi ;
+
+: process-phi-union ( ##phi dom-forest -- )
+ [ process-df-node ] with each ;
+
+: add-local-interferences ( ##phi -- )
+ [ phi-union get ] dip dst>> '[ drop _ 2array , ] assoc-each ;
+
+: compute-local-interferences ( ##phi -- pairs )
+ [
+ [ phi-union get keys compute-dom-forest process-phi-union ]
+ [ add-local-interferences ]
+ bi
+ ] { } make ;
+
+:: insert-copies-for-interference ( ##phi src -- )
+ ##phi inputs>> [| bb src' |
+ src src' eq? [ bb src ##phi dst>> insert-copy ] when
+ ] assoc-each ;
+
+: process-local-interferences ( ##phi pairs -- )
+ [
+ first2 2dup interferes?
+ [ drop insert-copies-for-interference ] [ 3drop ] if
+ ] with each ;
+
+: add-renaming-set ( ##phi -- )
+ [ phi-union get ] dip dst>> renaming-sets get set-at
+ phi-union get [ drop processed-name ] assoc-each ;
+
+: process-phi ( ##phi -- )
+ H{ } clone phi-union set
+ H{ } clone unioned-blocks set
+ [ [ inputs>> ] [ dst>> ] bi '[ _ process-phi-operand ] assoc-each ]
+ [ dup compute-local-interferences process-local-interferences ]
+ [ add-renaming-set ]
+ tri ;
+
+: process-block ( bb -- )
+ instructions>>
+ [ dup ##phi? [ process-phi t ] [ drop f ] if ] all? drop ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs fry kernel namespaces sequences
+compiler.cfg.ssa.destruction.state compiler.cfg.renaming compiler.cfg.rpo
+disjoint-sets ;
+IN: compiler.cfg.ssa.destruction.renaming
+
+: build-disjoint-set ( assoc -- disjoint-set )
+ <disjoint-set> dup [
+ '[
+ [ _ add-atom ]
+ [ [ drop _ add-atom ] assoc-each ]
+ bi*
+ ] assoc-each
+ ] keep ;
+
+: update-congruence-class ( dst assoc disjoint-set -- )
+ [ keys swap ] dip equate-all-with ;
+
+: build-congruence-classes ( -- disjoint-set )
+ renaming-sets get
+ dup build-disjoint-set
+ [ '[ _ update-congruence-class ] assoc-each ] keep ;
+
+: compute-renaming ( disjoint-set -- assoc )
+ [ parents>> ] keep
+ '[ drop dup _ representative ] assoc-map ;
+
+: rename-blocks ( cfg -- )
+ [
+ instructions>> [
+ [ rename-insn-defs ]
+ [ rename-insn-uses ] bi
+ ] each
+ ] each-basic-block ;
+
+: rename-copies ( -- )
+ waiting renamings get '[
+ [
+ [ _ [ ?at drop ] [ '[ _ ?at drop ] map ] bi-curry bi* ] assoc-map
+ ] assoc-map
+ ] change ;
+
+: perform-renaming ( cfg -- )
+ build-congruence-classes compute-renaming renamings set
+ rename-blocks
+ rename-copies ;
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces sets kernel assocs ;
+IN: compiler.cfg.ssa.destruction.state
+
+SYMBOLS: processed-names waiting used-by-another renaming-sets ;
+
+: init-coalescing ( -- )
+ H{ } clone renaming-sets set
+ H{ } clone processed-names set
+ H{ } clone waiting set
+ V{ } clone used-by-another set ;
+
+: processed-name ( vreg -- ) processed-names get conjoin ;
+
+: waiting-for ( bb -- assoc ) waiting get [ drop H{ } clone ] cache ;
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization
-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 ;
-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 ;
-
-: linearize ( cfg -- mr )
- flatten-cfg instructions>> ;
-
-local-only? off
-
-[ ] [ [ ] test-stack-analysis drop ] unit-test
-
-! Only peek once
-[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test
-
-! Redundant replace is redundant
-[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
-[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
-
-! Replace required here
-[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
-[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
-
-! Only one replace, at the end
-[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test
-
-! Do we support the full language?
-[ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test
-[ ] [ [ { [ ] [ ] } dispatch dup ] test-stack-analysis drop ] unit-test
-[ ] [
- [ "int" { "int" "int" } "cdecl" [ + ] alien-callback ]
- test-cfg second test-stack-analysis drop
-] unit-test
-
-! Test loops
-[ ] [ [ [ t ] loop ] test-stack-analysis drop ] unit-test
-[ ] [ [ [ dup ] loop ] test-stack-analysis drop ] unit-test
-
-! Make sure that peeks are inserted in the right place
-[ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test
-
-! This should be a total no-op
-[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
-
-! Don't insert inc-d/inc-r; that's wrong!
-[ 1 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test
-
-! Bug in height tracking
-[ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test
-[ ] [ [ dup [ ] [ dup reverse drop ] if ] test-stack-analysis drop ] unit-test
-[ ] [ [ [ drop dup 4.0 > ] find-last-integer ] test-stack-analysis drop ] unit-test
-
-! Bugs with code that throws
-[ ] [ [ [ "Oops" throw ] unless ] test-stack-analysis drop ] unit-test
-[ ] [ [ [ ] (( -- * )) call-effect-unsafe ] test-stack-analysis drop ] unit-test
-[ ] [ [ dup [ "Oops" throw ] when dup ] test-stack-analysis drop ] unit-test
-[ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test
-
-! Make sure the replace stores a value with the right height
-[ ] [
- [ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize
- [ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi
-] unit-test
-
-! translate-loc was the wrong way round
-[ ] [
- [ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize
- [ [ ##load-immediate? ] count 2 assert= ]
- [ [ ##peek? ] count 1 assert= ]
- [ [ ##replace? ] count 3 assert= ]
- tri
-] unit-test
-
-[ ] [
- [ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize
- [ [ ##load-immediate? ] count 2 assert= ]
- [ [ ##peek? ] count 1 assert= ]
- [ [ ##replace? ] count 1 assert= ]
- tri
-] unit-test
-
-! Sync before a back-edge, not after
-! ##peeks should be inserted before a ##loop-entry
-! Don't optimize out the constants
-[ 1 t ] [
- [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
- [ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
-] unit-test
+++ /dev/null
-! 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 compiler.cfg.copy-prop compiler.cfg.def-use
-compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo
-compiler.cfg.hats compiler.cfg ;
-IN: compiler.cfg.stack-analysis
-
-! Convert stack operations to register operations
-
-! If 'poisoned' is set, disregard height information. This is set if we don't have
-! height change information for an instruction.
-TUPLE: state locs>vregs actual-locs>vregs changed-locs ds-height rs-height poisoned? ;
-
-: <state> ( -- state )
- state new
- H{ } clone >>locs>vregs
- H{ } clone >>actual-locs>vregs
- H{ } clone >>changed-locs
- 0 >>ds-height
- 0 >>rs-height ;
-
-M: state clone
- call-next-method
- [ clone ] change-locs>vregs
- [ clone ] change-actual-locs>vregs
- [ clone ] change-changed-locs ;
-
-: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ;
-
-: record-peek ( dst loc -- )
- state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ;
-
-: changed-loc ( loc -- )
- state get changed-locs>> conjoin ;
-
-: record-replace ( src loc -- )
- dup changed-loc state get locs>vregs>> set-at ;
-
-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> ;
-
-: redundant-replace? ( vreg loc -- ? )
- dup 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 ;
-
-: clear-state ( state -- )
- [ locs>vregs>> clear-assoc ]
- [ actual-locs>vregs>> clear-assoc ]
- [ changed-locs>> clear-assoc ]
- tri ;
-
-ERROR: poisoned-state state ;
-
-: sync-state ( -- )
- state get {
- [ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
- [ save-changed-locs ]
- [ clear-state ]
- } cleave ;
-
-: poison-state ( -- ) state get t >>poisoned? drop ;
-
-! Abstract interpretation
-GENERIC: visit ( insn -- )
-
-! Instructions which don't have any effect on the stack
-UNION: neutral-insn
- ##flushable
- ##effect ;
-
-M: neutral-insn visit , ;
-
-UNION: sync-if-back-edge
- ##branch
- ##conditional-branch
- ##compare-imm-branch
- ##dispatch
- ##loop-entry ;
-
-SYMBOL: local-only?
-
-t local-only? set-global
-
-: back-edge? ( from to -- ? )
- [ number>> ] bi@ > ;
-
-: sync-state? ( -- ? )
- basic-block get successors>>
- [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any?
- local-only? get or ;
-
-M: sync-if-back-edge visit
- sync-state? [ sync-state ] when , ;
-
-: adjust-d ( n -- ) state get [ + ] change-ds-height drop ;
-
-M: ##inc-d visit [ , ] [ n>> adjust-d ] bi ;
-
-: adjust-r ( n -- ) state get [ + ] change-rs-height drop ;
-
-M: ##inc-r visit [ , ] [ n>> adjust-r ] bi ;
-
-: 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 ;
-
-M: ##replace visit
- [ src>> resolve ] [ loc>> translate-loc ] bi
- record-replace ;
-
-M: ##copy visit
- [ call-next-method ] [ record-copy ] bi ;
-
-M: ##call visit
- [ call-next-method ] [ height>> adjust-d ] 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-d ;
-
-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 ;
-
-: initial-state ( bb states -- state ) 2drop <state> ;
-
-: single-predecessor ( bb states -- state ) nip first clone ;
-
-ERROR: must-equal-failed seq ;
-
-: must-equal ( seq -- elt )
- dup all-equal? [ first ] [ must-equal-failed ] if ;
-
-: merge-heights ( state predecessors states -- state )
- nip
- [ [ ds-height>> ] map must-equal >>ds-height ]
- [ [ rs-height>> ] map must-equal >>rs-height ] bi ;
-
-: insert-peek ( predecessor loc -- vreg )
- ! XXX critical edges
- '[ _ ^^peek ] add-instructions ;
-
-: merge-loc ( predecessors locs>vregs loc -- 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 ;
-
-: merge-locs ( state predecessors states -- state )
- [ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
-
-: merge-loc' ( locs>vregs loc -- vreg )
- ! Insert a ##phi in the current block where the input
- ! is the vreg storing loc from each predecessor block
- '[ [ _ ] dip at ] map
- 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-loc' ] 2bi ] with
- H{ } map>assoc
- [ nip ] assoc-filter
- >>actual-locs>vregs ;
-
-: merge-changed-locs ( state predecessors states -- state )
- nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
-
-ERROR: cannot-merge-poisoned states ;
-
-: multiple-predecessors ( bb states -- state )
- dup [ not ] any? [
- [ <state> ] 2dip
- sift merge-heights
- ] [
- dup [ poisoned?>> ] any? [
- cannot-merge-poisoned
- ] [
- [ state new ] 2dip
- [ predecessors>> ] dip
- {
- [ merge-locs ]
- [ merge-actual-locs ]
- [ merge-heights ]
- [ merge-changed-locs ]
- } 2cleave
- ] if
- ] 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 ;
-
-: 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 ;
-
-: visit-block ( bb -- )
- ! block-in-state may add phi nodes at the start of the basic block
- ! so we wrap the whole thing with a 'make'
- [
- 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
- ] V{ } make >>instructions drop ;
-
-: stack-analysis ( cfg -- cfg' )
- [
- H{ } clone copies set
- H{ } clone state-in set
- H{ } clone state-out set
- dup [ visit-block ] each-basic-block
- ] with-scope ;
: 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: namespaces assocs kernel fry accessors sequences make math
+combinators compiler.cfg compiler.cfg.hats compiler.cfg.instructions
+compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.stacks.local
+compiler.cfg.stacks.global compiler.cfg.stacks.height ;
+IN: compiler.cfg.stacks.finalize
+
+! This pass inserts peeks and replaces.
+
+: inserting-peeks ( from to -- assoc )
+ peek-in swap [ peek-out ] [ avail-out ] bi
+ assoc-union assoc-diff ;
+
+: inserting-replaces ( from to -- assoc )
+ [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi*
+ assoc-union assoc-diff ;
+
+: each-insertion ( assoc bb quot: ( vreg loc -- ) -- )
+ '[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline
+
+ERROR: bad-peek dst loc ;
+
+: insert-peeks ( from to -- )
+ [ inserting-peeks ] keep
+ [ dup n>> 0 < [ bad-peek ] [ ##peek ] if ] each-insertion ;
+
+: insert-replaces ( from to -- )
+ [ inserting-replaces ] keep
+ [ dup n>> 0 < [ 2drop ] [ ##replace ] if ] each-insertion ;
+
+: visit-edge ( from to -- )
+ 2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make
+ [ 2drop ] [ <simple-block> insert-basic-block ] if-empty ;
+
+: visit-block ( bb -- )
+ [ predecessors>> ] keep '[ _ visit-edge ] each ;
+
+: finalize-stack-shuffling ( cfg -- cfg' )
+ dup [ visit-block ] each-basic-block
+ cfg-changed ;
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel combinators compiler.cfg.dataflow-analysis
+compiler.cfg.stacks.local ;
+IN: compiler.cfg.stacks.global
+
+! Peek analysis. Peek-in is the set of all locations anticipated at
+! the start of a basic block.
+BACKWARD-ANALYSIS: peek
+
+M: peek-analysis transfer-set drop [ replace-set assoc-diff ] keep peek-set assoc-union ;
+
+! Replace analysis. Replace-in is the set of all locations which
+! will be overwritten at some point after the start of a basic block.
+FORWARD-ANALYSIS: replace
+
+M: replace-analysis transfer-set drop replace-set assoc-union ;
+
+! Availability analysis. Avail-out is the set of all locations
+! in registers at the end of a basic block.
+FORWARD-ANALYSIS: avail
+
+M: avail-analysis transfer-set drop [ peek-set ] [ replace-set ] bi assoc-union assoc-union ;
+
+! Kill analysis. Kill-in is the set of all locations
+! which are going to be overwritten.
+BACKWARD-ANALYSIS: kill
+
+M: kill-analysis transfer-set drop replace-set assoc-union ;
+
+! Main word
+: compute-global-sets ( cfg -- cfg' )
+ {
+ [ compute-peek-sets ]
+ [ compute-replace-sets ]
+ [ compute-avail-sets ]
+ [ compute-kill-sets ]
+ [ ]
+ } cleave ;
\ 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 fry kernel math
+namespaces compiler.cfg.registers ;
+IN: compiler.cfg.stacks.height
+
+! Global stack height tracking done while constructing CFG.
+SYMBOLS: ds-heights rs-heights ;
+
+: record-stack-heights ( ds-height rs-height bb -- )
+ [ ds-heights get set-at ] [ rs-heights get set-at ] bi-curry bi* ;
+
+GENERIC# translate-loc 1 ( loc bb -- loc' )
+
+M: ds-loc translate-loc [ n>> ] [ ds-heights get at ] bi* - <ds-loc> ;
+M: rs-loc translate-loc [ n>> ] [ rs-heights get at ] bi* - <rs-loc> ;
+
+: translate-locs ( assoc bb -- assoc' )
+ '[ [ _ translate-loc ] dip ] assoc-map ;
+
+GENERIC# untranslate-loc 1 ( loc bb -- loc' )
+
+M: ds-loc untranslate-loc [ n>> ] [ ds-heights get at ] bi* + <ds-loc> ;
+M: rs-loc untranslate-loc [ n>> ] [ rs-heights get at ] bi* + <rs-loc> ;
+
+: untranslate-locs ( assoc bb -- assoc' )
+ '[ [ _ untranslate-loc ] dip ] assoc-map ;
\ 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 kernel math namespaces sets make sequences
+compiler.cfg
+compiler.cfg.hats
+compiler.cfg.instructions
+compiler.cfg.registers
+compiler.cfg.stacks.height
+compiler.cfg.parallel-copy ;
+IN: compiler.cfg.stacks.local
+
+! Local stack analysis. We build local peek and replace sets for every basic
+! block while constructing the CFG.
+
+SYMBOLS: peek-sets replace-sets ;
+
+SYMBOL: locs>vregs
+
+: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
+: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
+
+TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ;
+
+SYMBOLS: local-peek-set local-replace-set replace-mapping ;
+
+GENERIC: translate-local-loc ( loc -- loc' )
+M: ds-loc translate-local-loc n>> current-height get d>> - <ds-loc> ;
+M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
+
+: emit-stack-changes ( -- )
+ replace-mapping get dup assoc-empty? [ drop ] [
+ [ [ loc>vreg ] dip ] assoc-map parallel-copy
+ ] if ;
+
+: emit-height-changes ( -- )
+ current-height get
+ [ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ]
+ [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi ;
+
+: emit-changes ( -- )
+ ! Insert height and stack changes prior to the last instruction
+ building get pop
+ emit-stack-changes
+ emit-height-changes
+ , ;
+
+! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later
+: inc-d ( n -- )
+ current-height get
+ [ [ + ] change-emit-d drop ]
+ [ [ + ] change-d drop ]
+ 2bi ;
+
+: inc-r ( n -- )
+ current-height get
+ [ [ + ] change-emit-r drop ]
+ [ [ + ] change-r drop ]
+ 2bi ;
+
+: peek-loc ( loc -- vreg )
+ translate-local-loc
+ dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless
+ dup replace-mapping get at [ ] [ loc>vreg ] ?if ;
+
+: replace-loc ( vreg loc -- )
+ translate-local-loc
+ 2dup loc>vreg =
+ [ nip replace-mapping get delete-at ]
+ [
+ [ local-replace-set get conjoin ]
+ [ replace-mapping get set-at ]
+ bi
+ ] if ;
+
+: begin-local-analysis ( -- )
+ H{ } clone local-peek-set set
+ H{ } clone local-replace-set set
+ H{ } clone replace-mapping set
+ current-height get 0 >>emit-d 0 >>emit-r drop
+ current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ;
+
+: end-local-analysis ( -- )
+ emit-changes
+ local-peek-set get basic-block get peek-sets get set-at
+ local-replace-set get basic-block get replace-sets get set-at ;
+
+: clone-current-height ( -- )
+ current-height [ clone ] change ;
+
+: peek-set ( bb -- assoc ) peek-sets get at ;
+: replace-set ( bb -- assoc ) replace-sets get at ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: math sequences kernel cpu.architecture
-compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.hats ;
+USING: math sequences kernel namespaces accessors biassocs compiler.cfg
+compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats
+compiler.cfg.predecessors compiler.cfg.stacks.local
+compiler.cfg.stacks.height compiler.cfg.stacks.global
+compiler.cfg.stacks.finalize ;
IN: compiler.cfg.stacks
-: ds-drop ( -- )
- -1 ##inc-d ;
+: begin-stack-analysis ( -- )
+ <bihash> locs>vregs set
+ H{ } clone ds-heights set
+ H{ } clone rs-heights set
+ H{ } clone peek-sets set
+ H{ } clone replace-sets set
+ current-height new current-height set ;
-: ds-pop ( -- vreg )
- D 0 ^^peek -1 ##inc-d ;
+: end-stack-analysis ( -- )
+ cfg get
+ compute-predecessors
+ compute-global-sets
+ finalize-stack-shuffling
+ drop ;
-: ds-push ( vreg -- )
- 1 ##inc-d D 0 ##replace ;
+: ds-drop ( -- ) -1 inc-d ;
+
+: ds-peek ( -- vreg ) D 0 peek-loc ;
+
+: ds-pop ( -- vreg ) ds-peek ds-drop ;
+
+: ds-push ( vreg -- ) 1 inc-d D 0 replace-loc ;
: ds-load ( n -- vregs )
dup 0 =
[ drop f ]
- [ [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ] if ;
+ [ [ <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
: ds-store ( vregs -- )
[
<reversed>
- [ length ##inc-d ]
- [ [ <ds-loc> ##replace ] each-index ] bi
+ [ length inc-d ]
+ [ [ <ds-loc> replace-loc ] each-index ] bi
] unless-empty ;
+: rs-drop ( -- ) -1 inc-r ;
+
: rs-load ( n -- vregs )
dup 0 =
[ drop f ]
- [ [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ] if ;
+ [ [ <reversed> [ <rs-loc> peek-loc ] map ] [ neg inc-r ] bi ] if ;
: rs-store ( vregs -- )
[
<reversed>
- [ length ##inc-r ]
- [ [ <rs-loc> ##replace ] each-index ] bi
+ [ length inc-r ]
+ [ [ <rs-loc> replace-loc ] each-index ] bi
] unless-empty ;
+: (2inputs) ( -- vreg1 vreg2 )
+ D 1 peek-loc D 0 peek-loc ;
+
: 2inputs ( -- vreg1 vreg2 )
- D 1 ^^peek D 0 ^^peek -2 ##inc-d ;
+ (2inputs) -2 inc-d ;
+
+: (3inputs) ( -- vreg1 vreg2 vreg3 )
+ D 2 peek-loc D 1 peek-loc D 0 peek-loc ;
: 3inputs ( -- vreg1 vreg2 vreg3 )
- D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ;
+ (3inputs) -3 inc-d ;
+
+! adjust-d/adjust-r: these are called when other instructions which
+! internally adjust the stack height are emitted, such as ##call and
+! ##alien-invoke
+: adjust-d ( n -- ) current-height get [ + ] change-d drop ;
+: adjust-r ( n -- ) current-height get [ + ] change-r drop ;
+
--- /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
--- /dev/null
+IN: compiler.cfg.two-operand.tests
+USING: compiler.cfg.two-operand compiler.cfg.instructions
+compiler.cfg.registers cpu.architecture namespaces tools.test ;
+
+3 vreg-counter set-global
+
+[
+ V{
+ T{ ##copy f V int-regs 1 V int-regs 2 }
+ T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 3 }
+ }
+] [
+ {
+ T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 3 }
+ } (convert-two-operand)
+] unit-test
+
+[
+ V{
+ T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 2 }
+ }
+] [
+ {
+ T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 2 }
+ } (convert-two-operand)
+] unit-test
+
+[
+ V{
+ T{ ##copy f V int-regs 4 V int-regs 2 }
+ T{ ##sub f V int-regs 4 V int-regs 4 V int-regs 1 }
+ T{ ##copy f V int-regs 1 V int-regs 4 }
+ }
+] [
+ {
+ T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 1 }
+ } (convert-two-operand)
+] unit-test
+
+! This should never come up after coalescing
+[
+ V{
+ T{ ##fixnum-add f V int-regs 2 V int-regs 4 V int-regs 2 }
+ } (convert-two-operand)
+] must-fail
! 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 ;
+USING: accessors kernel sequences make combinators
+compiler.cfg.registers compiler.cfg.instructions
+compiler.cfg.rpo cpu.architecture ;
IN: compiler.cfg.two-operand
-! On x86, instructions take the form x = x op y
-! Our SSA IR is x = y op z
+! This pass runs after SSA coalescing and normalizes instructions
+! to fit the x86 two-address scheme. Possibilities are:
+
+! 1) x = x op y
+! 2) x = y op x
+! 3) x = y op z
+
+! In case 1, there is nothing to do.
+
+! In case 2, we convert to
+! z = y
+! z = z op x
+! x = z
+
+! In case 3, we convert to
+! x = y
+! x = x op z
+
+! In case 2 and case 3, linear scan coalescing will eliminate a
+! copy if the value y is never used again.
! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm
! 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
+UNION: two-operand-insn
+ ##sub
+ ##mul
+ ##and
+ ##and-imm
+ ##or
+ ##or-imm
+ ##xor
+ ##xor-imm
+ ##shl
+ ##shl-imm
+ ##shr
+ ##shr-imm
+ ##sar
+ ##sar-imm
+ ##fixnum-overflow
+ ##add-float
+ ##sub-float
+ ##mul-float
+ ##div-float ;
-: make-copy/float ( dst src -- insn ) \ ##copy-float new-insn ; inline
+GENERIC: convert-two-operand* ( insn -- )
-: convert-two-operand/integer ( insn -- )
- [ [ dst>> ] [ src1>> ] bi ##copy ]
- [ dup dst>> >>src1 , ]
- bi ; inline
+: emit-copy ( dst src -- )
+ dup reg-class>> {
+ { int-regs [ ##copy ] }
+ { double-float-regs [ ##copy-float ] }
+ } case ; inline
-: convert-two-operand/float ( insn -- )
- [ [ dst>> ] [ src1>> ] bi ##copy-float ]
+: case-1? ( insn -- ? ) [ dst>> ] [ src1>> ] bi = ; inline
+
+: case-1 ( insn -- ) , ; inline
+
+: case-2? ( insn -- ? ) [ dst>> ] [ src2>> ] bi = ; inline
+
+ERROR: bad-case-2 insn ;
+
+: case-2 ( insn -- )
+ ! This can't work with a ##fixnum-overflow since it branches
+ dup ##fixnum-overflow? [ bad-case-2 ] when
+ dup dst>> reg-class>> next-vreg
+ [ swap src1>> emit-copy ]
+ [ [ >>src1 ] [ >>dst ] bi , ]
+ [ [ src2>> ] dip emit-copy ]
+ 2tri ; inline
+
+: case-3 ( insn -- )
+ [ [ dst>> ] [ src1>> ] bi emit-copy ]
[ dup dst>> >>src1 , ]
bi ; inline
-GENERIC: convert-two-operand* ( insn -- )
+M: two-operand-insn convert-two-operand*
+ {
+ { [ dup case-1? ] [ case-1 ] }
+ { [ dup case-2? ] [ case-2 ] }
+ [ case-3 ]
+ } cond ; inline
M: ##not convert-two-operand*
- [ [ dst>> ] [ src>> ] bi ##copy ]
- [ dup dst>> >>src , ]
- bi ;
-
-M: ##sub convert-two-operand* convert-two-operand/integer ;
-M: ##mul convert-two-operand* convert-two-operand/integer ;
-M: ##and convert-two-operand* convert-two-operand/integer ;
-M: ##and-imm convert-two-operand* convert-two-operand/integer ;
-M: ##or convert-two-operand* convert-two-operand/integer ;
-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-imm convert-two-operand* convert-two-operand/integer ;
-M: ##shr-imm convert-two-operand* convert-two-operand/integer ;
-M: ##sar-imm 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 ;
-M: ##div-float convert-two-operand* convert-two-operand/float ;
+ dup [ dst>> ] [ src>> ] bi = [
+ [ [ dst>> ] [ src>> ] bi ##copy ]
+ [ dup dst>> >>src ]
+ bi
+ ] unless , ;
M: insn convert-two-operand* , ;
+: (convert-two-operand) ( cfg -- cfg' )
+ [ [ convert-two-operand* ] each ] V{ } make ;
+
: convert-two-operand ( cfg -- cfg' )
- two-operand? [
- [ drop ]
- [ [ [ convert-two-operand* ] each ] V{ } make ]
- local-optimization
- ] when ;
+ two-operand? [ [ (convert-two-operand) ] local-optimization ] when ;
\ No newline at end of file
+++ /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
+cpu.architecture kernel layouts locals make math namespaces sequences
+sets vectors fry compiler.cfg compiler.cfg.instructions
+compiler.cfg.rpo ;
IN: compiler.cfg.utilities
-: value-info-small-fixnum? ( value-info -- ? )
- literal>> {
- { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
- [ drop f ]
- } cond ;
-
-: value-info-small-tagged? ( value-info -- ? )
- dup literal?>> [
- literal>> {
- { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
- { [ dup not ] [ drop t ] }
- [ drop f ]
- } cond
- ] [ drop f ] if ;
-
-: set-basic-block ( basic-block -- )
- [ basic-block set ] [ instructions>> building set ] bi ;
-
-: begin-basic-block ( -- )
- <basic-block> basic-block get [
- dupd successors>> push
- ] when*
- set-basic-block ;
-
-: end-basic-block ( -- )
- building off
- basic-block off ;
-
-: stop-iterating ( -- next ) end-basic-block f ;
-
-: call-height ( ##call -- n )
- [ out-d>> length ] [ in-d>> length ] bi - ;
-
-: emit-primitive ( node -- )
- [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ;
+PREDICATE: kill-block < basic-block
+ instructions>> {
+ [ length 2 = ]
+ [ first kill-vreg-insn? ]
+ } 1&& ;
+
+: back-edge? ( from to -- ? )
+ [ number>> ] bi@ >= ;
+
+: loop-entry? ( bb -- ? )
+ dup predecessors>> [ swap back-edge? ] with any? ;
+
+: 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 ;
+
+:: 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 ;
+
+: has-phis? ( bb -- ? )
+ instructions>> first ##phi? ;
+
+: cfg-has-phis? ( cfg -- ? )
+ post-order [ has-phis? ] any? ;
+
+: if-has-phis ( bb quot: ( bb -- ) -- )
+ [ dup has-phis? ] dip [ drop ] if ; inline
+
+: predecessor ( bb -- pred )
+ predecessors>> first ; inline
+
-! 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 )
+
+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 ;
+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 number-values rewrite
- ] when
- dup ##compare-imm? [
- dup rewrite-tagged-comparison? [
- rewrite-tagged-comparison
- dup number-values rewrite
- ] when
- ] when ;
-
-M: insn 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 ;
{ [ dup integer? ] [ nip ] }
} cond ;
-GENERIC: number-values ( insn -- )
-
-M: ##flushable number-values [ >expr simplify ] [ dst>> ] bi set-vn ;
-M: insn number-values drop ;
+: number-values ( insn -- )
+ [ >expr simplify ] [ dst>> ] bi set-vn ;
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.dce compiler.cfg.ssa.destruction
+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{ ##copy f V int-regs 1 V int-regs 0 }
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##replace f V int-regs 1 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
-] 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{ ##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 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{ ##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{ ##load-reference f V int-regs 0 t }
+ T{ ##copy f V int-regs 1 V int-regs 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 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{ ##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
+! Compare propagation
[
{
T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
- T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
- T{ ##replace f V int-regs 4 D 0 }
+ T{ ##copy f V int-regs 6 V int-regs 4 }
+ T{ ##replace f V int-regs 6 D 0 }
}
] [
{
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{ ##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 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{ ##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{ ##peek f V int-regs 1 D 1 }
+ T{ ##load-immediate f V int-regs 2 0 }
+ T{ ##copy f V int-regs 3 V int-regs 0 }
+ T{ ##replace f V int-regs 3 D 0 }
}
] [
- { 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{ ##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{ ##copy f V int-regs 3 V int-regs 0 }
+ T{ ##replace f V int-regs 3 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{ ##copy f V int-regs 3 V int-regs 0 }
+ T{ ##replace f V int-regs 3 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{ ##copy f V int-regs 3 V int-regs 0 }
+ T{ ##replace f V int-regs 3 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{ ##copy f V int-regs 2 V int-regs 0 }
+ T{ ##replace f V int-regs 2 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
+ destruct-ssa drop
+] unit-test
+
+[ 1 ] [ 1 get successors>> length ] unit-test
+
+[ t ] [ 1 get successors>> first 3 get eq? ] unit-test
+
+[ 2 ] [ 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
+USING: namespaces assocs kernel accessors
sorting sets sequences
-compiler.cfg.local
-compiler.cfg.liveness
+compiler.cfg
+compiler.cfg.rpo
+compiler.cfg.instructions
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
+: >copy ( insn -- insn/##copy )
+ dup dst>> dup vreg>vn vn>vreg
+ 2dup eq? [ 2drop ] [ \ ##copy new-insn nip ] if ;
-: init-value-numbering ( live-in -- )
- init-value-graph
- init-expressions
- number-input-values ;
+: rewrite-loop ( insn -- insn' )
+ dup rewrite [ rewrite-loop ] [ ] ?if ;
+
+GENERIC: process-instruction ( insn -- insn' )
+
+M: ##flushable process-instruction
+ dup rewrite
+ [ process-instruction ]
+ [ dup number-values >copy ] ?if ;
+
+M: insn process-instruction
+ dup rewrite
+ [ process-instruction ] [ ] ?if ;
: value-numbering-step ( insns -- insns' )
- [ [ number-values ] [ rewrite propagate ] bi ] map ;
+ init-value-graph
+ init-expressions
+ [ process-instruction ] map ;
: value-numbering ( cfg -- cfg' )
- [ init-value-numbering ] [ value-numbering-step ] local-optimization ;
+ [ value-numbering-step ] local-optimization cfg-changed ;
USING: compiler.cfg.write-barrier compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.debugger cpu.architecture
-arrays tools.test vectors compiler.cfg kernel accessors ;
+arrays tools.test vectors compiler.cfg kernel accessors
+compiler.cfg.utilities ;
IN: compiler.cfg.write-barrier.tests
: test-write-barrier ( insns -- insns )
- write-barriers-step ;
+ <simple-block> dup write-barriers-step instructions>> ;
[
- {
+ V{
T{ ##peek f V int-regs 4 D 0 f }
- T{ ##copy f V int-regs 6 V int-regs 4 f }
T{ ##allot f V int-regs 7 24 array V int-regs 8 f }
T{ ##load-immediate f V int-regs 9 8 f }
T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f }
- T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 f }
+ T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 f }
T{ ##replace f V int-regs 7 D 0 f }
+ T{ ##branch }
}
] [
{
T{ ##peek f V int-regs 4 D 0 }
- T{ ##copy f V int-regs 6 V int-regs 4 }
T{ ##allot f V int-regs 7 24 array V int-regs 8 }
T{ ##load-immediate f V int-regs 9 8 }
T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 }
T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 }
- T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 }
+ T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 }
T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 }
T{ ##replace f V int-regs 7 D 0 }
} test-write-barrier
] unit-test
[
- {
+ V{
T{ ##load-immediate f V int-regs 4 24 }
T{ ##peek f V int-regs 5 D -1 }
T{ ##peek f V int-regs 6 D -2 }
T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 }
T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 }
+ T{ ##branch }
}
] [
{
] unit-test
[
- {
+ V{
T{ ##peek f V int-regs 19 D -3 }
T{ ##peek f V int-regs 22 D -2 }
- T{ ##copy f V int-regs 23 V int-regs 19 }
- T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
- T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
- T{ ##copy f V int-regs 26 V int-regs 19 }
+ T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 }
+ T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 }
T{ ##peek f V int-regs 28 D -1 }
- T{ ##copy f V int-regs 29 V int-regs 19 }
- T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
+ T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 }
+ T{ ##branch }
}
] [
{
T{ ##peek f V int-regs 19 D -3 }
T{ ##peek f V int-regs 22 D -2 }
- T{ ##copy f V int-regs 23 V int-regs 19 }
- T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
- T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
- T{ ##copy f V int-regs 26 V int-regs 19 }
+ T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 }
+ T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 }
T{ ##peek f V int-regs 28 D -1 }
- T{ ##copy f V int-regs 29 V int-regs 19 }
- T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
- T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 }
+ T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 }
+ T{ ##write-barrier f V int-regs 19 V int-regs 30 V int-regs 3 }
} test-write-barrier
] unit-test
! Copyright (C) 2008, 2009 Slava Pestov.
! 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 ;
+USING: kernel accessors namespaces assocs sets sequences
+compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
IN: compiler.cfg.write-barrier
! Eliminate redundant write barrier hits.
! Objects which have been mutated
SYMBOL: mutated
-GENERIC: eliminate-write-barrier ( insn -- insn' )
+GENERIC: eliminate-write-barrier ( insn -- ? )
M: ##allot eliminate-write-barrier
- dup dst>> safe get conjoin ;
+ dst>> safe get conjoin t ;
M: ##write-barrier eliminate-write-barrier
- dup src>> resolve dup
- [ safe get key? not ]
- [ mutated get key? ] bi and
- [ safe get conjoin ] [ 2drop f ] if ;
-
-M: ##copy eliminate-write-barrier
- dup record-copy ;
+ src>> dup [ safe get key? not ] [ mutated get key? ] bi and
+ [ safe get conjoin t ] [ drop f ] if ;
M: ##set-slot eliminate-write-barrier
- dup obj>> resolve mutated get conjoin ;
+ obj>> mutated get conjoin t ;
M: ##set-slot-imm eliminate-write-barrier
- dup obj>> resolve mutated get conjoin ;
+ obj>> mutated get conjoin t ;
-M: insn eliminate-write-barrier ;
+M: insn eliminate-write-barrier drop t ;
-: write-barriers-step ( insns -- insns' )
+: write-barriers-step ( bb -- )
H{ } clone safe set
H{ } clone mutated set
- H{ } clone copies set
- [ eliminate-write-barrier ] map sift ;
+ instructions>> [ eliminate-write-barrier ] filter-here ;
: eliminate-write-barriers ( cfg -- cfg' )
- [ drop ] [ write-barriers-step ] local-optimization ;
+ dup [ write-barriers-step ] each-basic-block ;
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays alien.complex alien.libraries sets libc
-continuations.private fry cpu.architecture
+continuations.private fry cpu.architecture classes
source-files.errors
compiler.errors
compiler.alien
compiler.utilities ;
IN: compiler.codegen
-GENERIC: generate-insn ( insn -- )
-
-SYMBOL: registers
+SYMBOL: insn-counts
-: register ( vreg -- operand )
- registers get at [ "Bad value" throw ] unless* ;
+H{ } clone insn-counts set-global
-: ?register ( obj -- operand )
- dup vreg? [ register ] when ;
+GENERIC: generate-insn ( insn -- )
TUPLE: asm label code calls ;
[ word>> init-generator ]
[
instructions>>
- [ [ regs>> registers set ] [ generate-insn ] bi ] each
+ [
+ [ class insn-counts get inc-at ]
+ [ generate-insn ]
+ bi
+ ] each
] bi
] with-fixup ;
: 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 ;
+ [ dst>> ] [ val>> ] bi %load-immediate ;
M: ##load-reference generate-insn
- [ dst>> register ] [ obj>> ] bi %load-reference ;
+ [ dst>> ] [ obj>> ] bi %load-reference ;
M: ##peek generate-insn
- [ dst>> register ] [ loc>> ] bi %peek ;
+ [ dst>> ] [ loc>> ] bi %peek ;
M: ##replace generate-insn
- [ src>> register ] [ loc>> ] bi %replace ;
+ [ src>> ] [ loc>> ] bi %replace ;
M: ##inc-d generate-insn n>> %inc-d ;
M: ##return generate-insn drop %return ;
M: _dispatch generate-insn
- [ src>> register ] [ temp>> register ] bi %dispatch ;
+ [ src>> ] [ temp>> ] bi %dispatch ;
M: _dispatch-label generate-insn
label>> lookup-label
rc-absolute-cell label-fixup ;
: >slot< ( insn -- dst obj slot tag )
- {
- [ dst>> register ]
- [ obj>> register ]
- [ slot>> ?register ]
- [ tag>> ]
- } cleave ; inline
+ { [ dst>> ] [ obj>> ] [ slot>> ] [ tag>> ] } cleave ; inline
M: ##slot generate-insn
- [ >slot< ] [ temp>> register ] bi %slot ;
+ [ >slot< ] [ temp>> ] bi %slot ;
M: ##slot-imm generate-insn
>slot< %slot-imm ;
: >set-slot< ( insn -- src obj slot tag )
- {
- [ src>> register ]
- [ obj>> register ]
- [ slot>> ?register ]
- [ tag>> ]
- } cleave ; inline
+ { [ src>> ] [ obj>> ] [ slot>> ] [ tag>> ] } cleave ; inline
M: ##set-slot generate-insn
- [ >set-slot< ] [ temp>> register ] bi %set-slot ;
+ [ >set-slot< ] [ temp>> ] bi %set-slot ;
M: ##set-slot-imm generate-insn
>set-slot< %set-slot-imm ;
M: ##string-nth generate-insn
- {
- [ dst>> register ]
- [ obj>> register ]
- [ index>> register ]
- [ temp>> register ]
- } cleave %string-nth ;
+ { [ dst>> ] [ obj>> ] [ index>> ] [ temp>> ] } cleave %string-nth ;
M: ##set-string-nth-fast generate-insn
- {
- [ src>> register ]
- [ obj>> register ]
- [ index>> register ]
- [ temp>> register ]
- } cleave %set-string-nth-fast ;
+ { [ src>> ] [ obj>> ] [ index>> ] [ temp>> ] } cleave %set-string-nth-fast ;
: dst/src ( insn -- dst src )
- [ dst>> register ] [ src>> register ] bi ; inline
+ [ dst>> ] [ src>> ] bi ; inline
: dst/src1/src2 ( insn -- dst src1 src2 )
- [ dst>> register ]
- [ src1>> register ]
- [ src2>> ?register ] tri ; inline
+ [ dst>> ] [ src1>> ] [ src2>> ] tri ; inline
M: ##add generate-insn dst/src1/src2 %add ;
M: ##add-imm generate-insn dst/src1/src2 %add-imm ;
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
+ [ dst/src ] [ temp>> ] bi ; inline
M: ##integer>bignum generate-insn dst/src/temp %integer>bignum ;
M: ##bignum>integer generate-insn dst/src/temp %bignum>integer ;
M: ##alien-double generate-insn dst/src %alien-double ;
: >alien-setter< ( insn -- src value )
- [ src>> register ] [ value>> register ] bi ; inline
+ [ src>> ] [ value>> ] bi ; inline
M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
M: ##allot generate-insn
{
- [ dst>> register ]
+ [ dst>> ]
[ size>> ]
[ class>> ]
- [ temp>> register ]
+ [ temp>> ]
} cleave
%allot ;
M: ##write-barrier generate-insn
- [ src>> register ]
- [ card#>> register ]
- [ table>> register ]
+ [ src>> ]
+ [ card#>> ]
+ [ table>> ]
tri %write-barrier ;
M: _gc generate-insn
{
- [ temp1>> register ]
- [ temp2>> register ]
+ [ temp1>> ]
+ [ temp2>> ]
[ gc-roots>> ]
[ gc-root-count>> ]
} cleave %gc ;
-M: ##loop-entry generate-insn drop %loop-entry ;
+M: _loop-entry generate-insn drop %loop-entry ;
M: ##alien-global generate-insn
- [ dst>> register ] [ symbol>> ] [ library>> ] tri
+ [ dst>> ] [ symbol>> ] [ library>> ] tri
%alien-global ;
! ##alien-invoke
: objects>registers ( params -- )
#! Generate code for unboxing a list of C types, then
- #! generate code for moving these parameters to register on
+ #! generate code for moving these parameters to registers on
#! architectures where parameters are passed in registers.
[
[ prepare-box-struct ] keep
: >compare< ( insn -- dst temp cc src1 src2 )
{
- [ dst>> register ]
- [ temp>> register ]
+ [ dst>> ]
+ [ temp>> ]
[ cc>> ]
- [ src1>> register ]
- [ src2>> ?register ]
+ [ src1>> ]
+ [ src2>> ]
} cleave ; inline
M: ##compare generate-insn >compare< %compare ;
{
[ label>> lookup-label ]
[ cc>> ]
- [ src1>> register ]
- [ src2>> ?register ]
+ [ src1>> ]
+ [ src2>> ]
} cleave ; inline
M: _compare-branch generate-insn
[ 4294967295 B{ 255 255 255 255 } -1 ]
[
-1 <int> -1 <int>
- [ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ]
+ [ [ 0 alien-unsigned-4 swap ] [ 0 alien-signed-2 ] bi ]
compile-call
] unit-test
}
] [
[ { 1 2 3 } "x" "y" linear-scan-regression ] { } make
+] 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
+
+! Bug with ##return node construction
+: return-recursive-bug ( nodes -- ? )
+ { fixnum } declare [
+ dup 3 bitand 1 = [ drop t ] [
+ dup 3 bitand 2 = [
+ return-recursive-bug
+ ] [ drop f ] if
+ ] if
+ ] any? ; inline recursive
+
+[ t ] [ 3 [ return-recursive-bug ] compile-call ] unit-test
+
+! Coalescing reductions
+[ f ] [ V{ } 0 [ [ vector? ] both? ] compile-call ] unit-test
+[ f ] [ 0 V{ } [ [ vector? ] both? ] compile-call ] unit-test
+
+[ f ] [
+ f vector [
+ [ dup [ \ vector eq? ] [ drop f ] if ] dip
+ dup [ \ vector eq? ] [ drop f ] if
+ over rot [ drop ] [ nip ] 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
--- /dev/null
+USING: accessors assocs compiler compiler.cfg
+compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.mr
+compiler.cfg.registers compiler.codegen compiler.units
+cpu.architecture hashtables kernel namespaces sequences
+tools.test vectors words layouts literals math arrays
+alien.syntax ;
+IN: compiler.tests.low-level-ir
+
+: compile-cfg ( cfg -- word )
+ gensym
+ [ build-mr generate code>> ] dip
+ [ associate >alist modify-code-heap ] keep ;
+
+: compile-test-cfg ( -- word )
+ cfg new
+ 0 get >>entry
+ compile-cfg ;
+
+: compile-test-bb ( insns -- result )
+ V{ T{ ##prologue } T{ ##branch } } 0 test-bb
+ V{
+ T{ ##inc-d f 1 }
+ T{ ##replace f V int-regs 0 D 0 }
+ T{ ##branch }
+ } [ clone ] map append 1 test-bb
+ V{
+ T{ ##epilogue }
+ T{ ##return }
+ } [ clone ] map 2 test-bb
+ 0 get 1 get 1vector >>successors drop
+ 1 get 2 get 1vector >>successors drop
+ compile-test-cfg
+ execute( -- result ) ;
+
+! loading immediates
+[ f ] [
+ V{
+ T{ ##load-immediate f V int-regs 0 5 }
+ } compile-test-bb
+] unit-test
+
+[ "hello" ] [
+ V{
+ T{ ##load-reference f V int-regs 0 "hello" }
+ } compile-test-bb
+] unit-test
+
+! make sure slot access works when the destination is
+! one of the sources
+[ t ] [
+ V{
+ T{ ##load-immediate f V int-regs 1 $[ 2 cell log2 shift ] }
+ T{ ##load-reference f V int-regs 0 { t f t } }
+ T{ ##slot f V int-regs 0 V int-regs 0 V int-regs 1 $[ array tag-number ] V int-regs 2 }
+ } compile-test-bb
+] unit-test
+
+[ t ] [
+ V{
+ T{ ##load-reference f V int-regs 0 { t f t } }
+ T{ ##slot-imm f V int-regs 0 V int-regs 0 2 $[ array tag-number ] V int-regs 2 }
+ } compile-test-bb
+] unit-test
+
+[ t ] [
+ V{
+ T{ ##load-immediate f V int-regs 1 $[ 2 cell log2 shift ] }
+ T{ ##load-reference f V int-regs 0 { t f t } }
+ T{ ##set-slot f V int-regs 0 V int-regs 0 V int-regs 1 $[ array tag-number ] V int-regs 2 }
+ } compile-test-bb
+ dup first eq?
+] unit-test
+
+[ t ] [
+ V{
+ T{ ##load-reference f V int-regs 0 { t f t } }
+ T{ ##set-slot-imm f V int-regs 0 V int-regs 0 2 $[ array tag-number ] }
+ } compile-test-bb
+ dup first eq?
+] unit-test
+
+[ 8 ] [
+ V{
+ T{ ##load-immediate f V int-regs 0 4 }
+ T{ ##shl f V int-regs 0 V int-regs 0 V int-regs 0 }
+ } compile-test-bb
+] unit-test
+
+[ 4 ] [
+ V{
+ T{ ##load-immediate f V int-regs 0 4 }
+ T{ ##shl-imm f V int-regs 0 V int-regs 0 3 }
+ } compile-test-bb
+] unit-test
+
+[ 31 ] [
+ V{
+ T{ ##load-reference f V int-regs 1 B{ 31 67 52 } }
+ T{ ##unbox-any-c-ptr f V int-regs 0 V int-regs 1 V int-regs 2 }
+ T{ ##alien-unsigned-1 f V int-regs 0 V int-regs 0 }
+ T{ ##shl-imm f V int-regs 0 V int-regs 0 3 }
+ } compile-test-bb
+] unit-test
+
+[ CHAR: l ] [
+ V{
+ T{ ##load-reference f V int-regs 0 "hello world" }
+ T{ ##load-immediate f V int-regs 1 3 }
+ T{ ##string-nth f V int-regs 0 V int-regs 0 V int-regs 1 V int-regs 2 }
+ T{ ##shl-imm f V int-regs 0 V int-regs 0 3 }
+ } compile-test-bb
+] unit-test
+
+[ 1 ] [
+ V{
+ T{ ##load-immediate f V int-regs 0 16 }
+ T{ ##add-imm f V int-regs 0 V int-regs 0 -8 }
+ } compile-test-bb
+] unit-test
+
+! These are def-is-use-insns
+USE: multiline
+
+/*
+
+[ 100 ] [
+ V{
+ T{ ##load-immediate f V int-regs 0 100 }
+ T{ ##integer>bignum f V int-regs 0 V int-regs 0 V int-regs 1 }
+ } compile-test-bb
+] unit-test
+
+[ 1 ] [
+ V{
+ T{ ##load-reference f V int-regs 0 ALIEN: 8 }
+ T{ ##unbox-any-c-ptr f V int-regs 0 V int-regs 0 V int-regs 1 }
+ } compile-test-bb
+] unit-test
+
+*/
\ No newline at end of file
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
-arrays compiler.tree.propagation.copy ;
+namespaces sequences words combinators byte-arrays strings
+arrays layouts cpu.architecture compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
: false-class? ( class -- ? ) \ f class<= ;
[ 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?>> [
dup in-d>> last node-value-info
literal>> first immutable-tuple-class?
] [ drop f ] if ;
+
+: value-info-small-fixnum? ( value-info -- ? )
+ literal>> {
+ { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
+ [ drop f ]
+ } cond ;
+
+: value-info-small-tagged? ( value-info -- ? )
+ dup literal?>> [
+ literal>> {
+ { [ dup fixnum? ] [ tag-fixnum small-enough? ] }
+ { [ dup not ] [ drop t ] }
+ [ drop f ]
+ } cond
+ ] [ drop f ] if ;
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 ;
: make-bitmap-image ( dim quot -- image )
'[ <CGBitmapContext> &CGContextRelease @ ] make-memory-bitmap
- ARGB >>component-order ; inline
+ ARGB >>component-order
+ ubyte-components >>component-type ; inline
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 ;
[ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test
+! r-rm / m-r sse instruction
+[ { HEX: 0f HEX: 10 HEX: c1 } ] [ [ XMM0 XMM1 MOVUPS ] { } make ] unit-test
+[ { HEX: 0f HEX: 10 HEX: 01 } ] [ [ XMM0 ECX [] MOVUPS ] { } make ] unit-test
+[ { HEX: 0f HEX: 11 HEX: 08 } ] [ [ EAX [] XMM1 MOVUPS ] { } make ] unit-test
+
+[ { HEX: f3 HEX: 0f HEX: 10 HEX: c1 } ] [ [ XMM0 XMM1 MOVSS ] { } make ] unit-test
+[ { HEX: f3 HEX: 0f HEX: 10 HEX: 01 } ] [ [ XMM0 ECX [] MOVSS ] { } make ] unit-test
+[ { HEX: f3 HEX: 0f HEX: 11 HEX: 08 } ] [ [ EAX [] XMM1 MOVSS ] { } make ] unit-test
+
+[ { HEX: 66 HEX: 0f HEX: 6f HEX: c1 } ] [ [ XMM0 XMM1 MOVDQA ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: 6f HEX: 01 } ] [ [ XMM0 ECX [] MOVDQA ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: 7f HEX: 08 } ] [ [ EAX [] XMM1 MOVDQA ] { } make ] unit-test
+
+! r-rm only sse instruction
+[ { HEX: 66 HEX: 0f HEX: 2e HEX: c1 } ] [ [ XMM0 XMM1 UCOMISD ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: 2e HEX: 01 } ] [ [ XMM0 ECX [] UCOMISD ] { } make ] unit-test
+[ [ EAX [] XMM1 UCOMISD ] { } make ] must-fail
+[ { HEX: 66 HEX: 0f HEX: 38 HEX: 2a HEX: 01 } ] [ [ XMM0 ECX [] MOVNTDQA ] { } make ] unit-test
+
+! rm-r only sse instructions
+[ { HEX: 0f HEX: 2b HEX: 08 } ] [ [ EAX [] XMM1 MOVNTPS ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: e7 HEX: 08 } ] [ [ EAX [] XMM1 MOVNTDQ ] { } make ] unit-test
+
+! three-byte-opcode ssse3 instruction
+[ { HEX: 66 HEX: 0f HEX: 38 HEX: 02 HEX: c1 } ] [ [ XMM0 XMM1 PHADDD ] { } make ] unit-test
+
+! int/sse conversion instruction
[ { HEX: f2 HEX: 0f HEX: 2c HEX: c0 } ] [ [ EAX XMM0 CVTTSD2SI ] { } make ] unit-test
[ { HEX: f2 HEX: 48 HEX: 0f HEX: 2c HEX: c0 } ] [ [ RAX XMM0 CVTTSD2SI ] { } make ] unit-test
[ { HEX: f2 HEX: 4c HEX: 0f HEX: 2c HEX: e0 } ] [ [ R12 XMM0 CVTTSD2SI ] { } make ] unit-test
! [ { HEX: f2 HEX: 0f HEX: 11 HEX: 00 } ] [ [ RAX [] XMM0 MOVSD ] { } make ] unit-test
! [ { HEX: f2 HEX: 41 HEX: 0f HEX: 11 HEX: 04 HEX: 24 } ] [ [ R12 [] XMM0 MOVSD ] { } make ] unit-test
+! 3-operand r-rm-imm sse instructions
+[ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 2 PSHUFD ] { } make ] unit-test
+[ { HEX: 0f HEX: c6 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 2 SHUFPS ] { } make ] unit-test
+
+! scalar register insert/extract sse instructions
+[ { HEX: 66 HEX: 0f HEX: c4 HEX: c1 HEX: 02 } ] [ [ XMM0 ECX 2 PINSRW ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: c4 HEX: 04 HEX: 11 HEX: 03 } ] [ [ XMM0 ECX EDX [+] 3 PINSRW ] { } make ] unit-test
+
+[ { HEX: 66 HEX: 0f HEX: c5 HEX: c1 HEX: 02 } ] [ [ EAX XMM1 2 PEXTRW ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: 3a HEX: 15 HEX: 08 HEX: 02 } ] [ [ EAX [] XMM1 2 PEXTRW ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: 3a HEX: 15 HEX: 14 HEX: 08 HEX: 03 } ] [ [ EAX ECX [+] XMM2 3 PEXTRW ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: 3a HEX: 14 HEX: c8 HEX: 02 } ] [ [ EAX XMM1 2 PEXTRB ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: 3a HEX: 14 HEX: 08 HEX: 02 } ] [ [ EAX [] XMM1 2 PEXTRB ] { } make ] unit-test
+
+! sse shift instructions
+[ { HEX: 66 HEX: 0f HEX: 71 HEX: d0 HEX: 05 } ] [ [ XMM0 5 PSRLW ] { } make ] unit-test
+
+! sse comparison instructions
+[ { HEX: 66 HEX: 0f HEX: c2 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 CMPLEPD ] { } make ] unit-test
+
+! unique sse instructions
+[ { HEX: 0f HEX: 18 HEX: 00 } ] [ [ EAX [] PREFETCHNTA ] { } make ] unit-test
+[ { HEX: 0f HEX: 18 HEX: 08 } ] [ [ EAX [] PREFETCHT0 ] { } make ] unit-test
+[ { HEX: 0f HEX: 18 HEX: 10 } ] [ [ EAX [] PREFETCHT1 ] { } make ] unit-test
+[ { HEX: 0f HEX: 18 HEX: 18 } ] [ [ EAX [] PREFETCHT2 ] { } make ] unit-test
+[ { HEX: 0f HEX: ae HEX: 10 } ] [ [ EAX [] LDMXCSR ] { } make ] unit-test
+[ { HEX: 0f HEX: ae HEX: 18 } ] [ [ EAX [] STMXCSR ] { } make ] unit-test
+
+[ { HEX: 0f HEX: c3 HEX: 08 } ] [ [ EAX [] ECX MOVNTI ] { } make ] unit-test
+
+[ { HEX: 0f HEX: 50 HEX: c1 } ] [ [ EAX XMM1 MOVMSKPS ] { } make ] unit-test
+[ { HEX: 66 HEX: 0f HEX: 50 HEX: c1 } ] [ [ EAX XMM1 MOVMSKPD ] { } make ] unit-test
+
+[ { HEX: f3 HEX: 0f HEX: b8 HEX: c1 } ] [ [ EAX ECX POPCNT ] { } make ] unit-test
+[ { HEX: f3 HEX: 48 HEX: 0f HEX: b8 HEX: c1 } ] [ [ RAX RCX POPCNT ] { } make ] unit-test
+[ { HEX: f3 HEX: 0f HEX: b8 HEX: 01 } ] [ [ EAX ECX [] POPCNT ] { } make ] unit-test
+[ { HEX: f3 HEX: 0f HEX: b8 HEX: 04 HEX: 11 } ] [ [ EAX ECX EDX [+] POPCNT ] { } make ] unit-test
+
+[ { HEX: f2 HEX: 0f HEX: 38 HEX: f0 HEX: c1 } ] [ [ EAX CL CRC32B ] { } make ] unit-test
+[ { HEX: f2 HEX: 0f HEX: 38 HEX: f0 HEX: 01 } ] [ [ EAX ECX [] CRC32B ] { } make ] unit-test
+[ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: c1 } ] [ [ EAX ECX CRC32 ] { } make ] unit-test
+[ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: 01 } ] [ [ EAX ECX [] CRC32 ] { } make ] unit-test
+
+! memory address modes
[ { HEX: 8a HEX: 18 } ] [ [ BL RAX [] MOV ] { } make ] unit-test
[ { HEX: 66 HEX: 8b HEX: 18 } ] [ [ BX RAX [] MOV ] { } make ] unit-test
[ { HEX: 8b HEX: 18 } ] [ [ EBX RAX [] MOV ] { } make ] unit-test
[ { HEX: 48 HEX: 69 HEX: c1 HEX: 44 HEX: 03 HEX: 00 HEX: 00 } ] [ [ RAX RCX HEX: 344 IMUL3 ] { } make ] unit-test
[ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test
+
USING: arrays io.binary kernel combinators kernel.private math
namespaces make sequences words system layouts math.order accessors
cpu.x86.assembler.syntax ;
+QUALIFIED: sequences
IN: cpu.x86.assembler
! A postfix assembler for x86-32 and x86-64.
! Beware!
! Register operands -- eg, ECX
-REGISTERS: 8 AL CL DL BL ;
+REGISTERS: 8 AL CL DL BL SPL BPL SIL DIL R8B R9B R10B R11B R12B R13B R14B R15B ;
-REGISTERS: 16 AX CX DX BX SP BP SI DI ;
+ALIAS: AH SPL
+ALIAS: CH BPL
+ALIAS: DH SIL
+ALIAS: BH DIL
-REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI ;
+REGISTERS: 16 AX CX DX BX SP BP SI DI R8W R9W R10W R11W R12W R13W R14W R15W ;
+
+REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI R8D R9D R10D R11D R12D R13D R14D R15D ;
REGISTERS: 64
RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
-: extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ;
+: extended-opcode ( opcode -- opcode' )
+ dup array? [ OCT: 17 sequences:prefix ] [ OCT: 17 swap 2array ] if ;
: extended-opcode, ( opcode -- ) extended-opcode opcode, ;
! Misc
: NOP ( -- ) HEX: 90 , ;
+: PAUSE ( -- ) HEX: f3 , HEX: 90 , ;
+
+: RDPMC ( -- ) HEX: 0f , HEX: 33 , ;
! x87 Floating Point Unit
pick register-128? [ swapd ] [ BIN: 1 bitor ] if ;
: 2-operand-sse ( dst src op1 op2 -- )
- , direction-bit-sse extended-opcode (2-operand) ;
+ [ , ] when* direction-bit-sse extended-opcode (2-operand) ;
+
+: direction-op-sse ( dst src op1s -- dst' src' op1' )
+ pick register-128? [ swapd first ] [ second ] if ;
+
+: 2-operand-rm-mr-sse ( dst src op1{rm,mr} op2 -- )
+ [ , ] when* direction-op-sse extended-opcode (2-operand) ;
+
+: 2-operand-rm-sse ( dst src op1 op2 -- )
+ [ , ] when* swapd extended-opcode (2-operand) ;
+
+: 2-operand-mr-sse ( dst src op1 op2 -- )
+ [ , ] when* extended-opcode (2-operand) ;
: 2-operand-int/sse ( dst src op1 op2 -- )
- , swapd extended-opcode (2-operand) ;
+ [ , ] when* swapd extended-opcode (2-operand) ;
+
+: 3-operand-rm-sse ( dst src imm op1 op2 -- )
+ rot [ 2-operand-rm-sse ] dip , ;
+
+: 3-operand-mr-sse ( dst src imm op1 op2 -- )
+ rot [ 2-operand-mr-sse ] dip , ;
+: 3-operand-rm-mr-sse ( dst src imm op1 op2 -- )
+ rot [ 2-operand-rm-mr-sse ] dip , ;
+
+: 2-operand-sse-cmp ( dst src cmp op1 op2 -- )
+ 3-operand-rm-sse ; inline
+
+: 2-operand-sse-shift ( dst imm reg op1 op2 -- )
+ [ , ] when*
+ [ f HEX: 0f ] dip 2array 3array
+ swapd 1-operand , ;
+
+PRIVATE>
+
+: MOVUPS ( dest src -- ) HEX: 10 f 2-operand-sse ;
+: MOVUPD ( dest src -- ) HEX: 10 HEX: 66 2-operand-sse ;
+: MOVSD ( dest src -- ) HEX: 10 HEX: f2 2-operand-sse ;
+: MOVSS ( dest src -- ) HEX: 10 HEX: f3 2-operand-sse ;
+: MOVLPS ( dest src -- ) HEX: 12 f 2-operand-sse ;
+: MOVLPD ( dest src -- ) HEX: 12 HEX: 66 2-operand-sse ;
+: MOVDDUP ( dest src -- ) HEX: 12 HEX: f2 2-operand-rm-sse ;
+: MOVSLDUP ( dest src -- ) HEX: 12 HEX: f3 2-operand-rm-sse ;
+: UNPCKLPS ( dest src -- ) HEX: 14 f 2-operand-rm-sse ;
+: UNPCKLPD ( dest src -- ) HEX: 14 HEX: 66 2-operand-rm-sse ;
+: UNPCKHPS ( dest src -- ) HEX: 15 f 2-operand-rm-sse ;
+: UNPCKHPD ( dest src -- ) HEX: 15 HEX: 66 2-operand-rm-sse ;
+: MOVHPS ( dest src -- ) HEX: 16 f 2-operand-sse ;
+: MOVHPD ( dest src -- ) HEX: 16 HEX: 66 2-operand-sse ;
+: MOVSHDUP ( dest src -- ) HEX: 16 HEX: f3 2-operand-rm-sse ;
+
+: PREFETCHNTA ( mem -- ) { BIN: 000 f { HEX: 0f HEX: 18 } } 1-operand ;
+: PREFETCHT0 ( mem -- ) { BIN: 001 f { HEX: 0f HEX: 18 } } 1-operand ;
+: PREFETCHT1 ( mem -- ) { BIN: 010 f { HEX: 0f HEX: 18 } } 1-operand ;
+: PREFETCHT2 ( mem -- ) { BIN: 011 f { HEX: 0f HEX: 18 } } 1-operand ;
+
+: MOVAPS ( dest src -- ) HEX: 28 f 2-operand-sse ;
+: MOVAPD ( dest src -- ) HEX: 28 HEX: 66 2-operand-sse ;
+: CVTSI2SD ( dest src -- ) HEX: 2a HEX: f2 2-operand-int/sse ;
+: CVTSI2SS ( dest src -- ) HEX: 2a HEX: f3 2-operand-int/sse ;
+: MOVNTPS ( dest src -- ) HEX: 2b f 2-operand-mr-sse ;
+: MOVNTPD ( dest src -- ) HEX: 2b HEX: 66 2-operand-mr-sse ;
+: CVTTSD2SI ( dest src -- ) HEX: 2c HEX: f2 2-operand-int/sse ;
+: CVTTSS2SI ( dest src -- ) HEX: 2c HEX: f3 2-operand-int/sse ;
+: CVTSD2SI ( dest src -- ) HEX: 2d HEX: f2 2-operand-int/sse ;
+: CVTSS2SI ( dest src -- ) HEX: 2d HEX: f3 2-operand-int/sse ;
+: UCOMISS ( dest src -- ) HEX: 2e f 2-operand-rm-sse ;
+: UCOMISD ( dest src -- ) HEX: 2e HEX: 66 2-operand-rm-sse ;
+: COMISS ( dest src -- ) HEX: 2f f 2-operand-rm-sse ;
+: COMISD ( dest src -- ) HEX: 2f HEX: 66 2-operand-rm-sse ;
+
+: PSHUFB ( dest src -- ) { HEX: 38 HEX: 00 } HEX: 66 2-operand-rm-sse ;
+: PHADDW ( dest src -- ) { HEX: 38 HEX: 01 } HEX: 66 2-operand-rm-sse ;
+: PHADDD ( dest src -- ) { HEX: 38 HEX: 02 } HEX: 66 2-operand-rm-sse ;
+: PHADDSW ( dest src -- ) { HEX: 38 HEX: 03 } HEX: 66 2-operand-rm-sse ;
+: PMADDUBSW ( dest src -- ) { HEX: 38 HEX: 04 } HEX: 66 2-operand-rm-sse ;
+: PHSUBW ( dest src -- ) { HEX: 38 HEX: 05 } HEX: 66 2-operand-rm-sse ;
+: PHSUBD ( dest src -- ) { HEX: 38 HEX: 06 } HEX: 66 2-operand-rm-sse ;
+: PHSUBSW ( dest src -- ) { HEX: 38 HEX: 07 } HEX: 66 2-operand-rm-sse ;
+: PSIGNB ( dest src -- ) { HEX: 38 HEX: 08 } HEX: 66 2-operand-rm-sse ;
+: PSIGNW ( dest src -- ) { HEX: 38 HEX: 09 } HEX: 66 2-operand-rm-sse ;
+: PSIGND ( dest src -- ) { HEX: 38 HEX: 0a } HEX: 66 2-operand-rm-sse ;
+: PMULHRSW ( dest src -- ) { HEX: 38 HEX: 0b } HEX: 66 2-operand-rm-sse ;
+: PBLENDVB ( dest src -- ) { HEX: 38 HEX: 10 } HEX: 66 2-operand-rm-sse ;
+: BLENDVPS ( dest src -- ) { HEX: 38 HEX: 14 } HEX: 66 2-operand-rm-sse ;
+: BLENDVPD ( dest src -- ) { HEX: 38 HEX: 15 } HEX: 66 2-operand-rm-sse ;
+: PTEST ( dest src -- ) { HEX: 38 HEX: 17 } HEX: 66 2-operand-rm-sse ;
+: PABSB ( dest src -- ) { HEX: 38 HEX: 1c } HEX: 66 2-operand-rm-sse ;
+: PABSW ( dest src -- ) { HEX: 38 HEX: 1d } HEX: 66 2-operand-rm-sse ;
+: PABSD ( dest src -- ) { HEX: 38 HEX: 1e } HEX: 66 2-operand-rm-sse ;
+: PMOVSXBW ( dest src -- ) { HEX: 38 HEX: 20 } HEX: 66 2-operand-rm-sse ;
+: PMOVSXBD ( dest src -- ) { HEX: 38 HEX: 21 } HEX: 66 2-operand-rm-sse ;
+: PMOVSXBQ ( dest src -- ) { HEX: 38 HEX: 22 } HEX: 66 2-operand-rm-sse ;
+: PMOVSXWD ( dest src -- ) { HEX: 38 HEX: 23 } HEX: 66 2-operand-rm-sse ;
+: PMOVSXWQ ( dest src -- ) { HEX: 38 HEX: 24 } HEX: 66 2-operand-rm-sse ;
+: PMOVSXDQ ( dest src -- ) { HEX: 38 HEX: 25 } HEX: 66 2-operand-rm-sse ;
+: PMULDQ ( dest src -- ) { HEX: 38 HEX: 28 } HEX: 66 2-operand-rm-sse ;
+: PCMPEQQ ( dest src -- ) { HEX: 38 HEX: 29 } HEX: 66 2-operand-rm-sse ;
+: MOVNTDQA ( dest src -- ) { HEX: 38 HEX: 2a } HEX: 66 2-operand-rm-sse ;
+: PACKUSDW ( dest src -- ) { HEX: 38 HEX: 2b } HEX: 66 2-operand-rm-sse ;
+: PMOVZXBW ( dest src -- ) { HEX: 38 HEX: 30 } HEX: 66 2-operand-rm-sse ;
+: PMOVZXBD ( dest src -- ) { HEX: 38 HEX: 31 } HEX: 66 2-operand-rm-sse ;
+: PMOVZXBQ ( dest src -- ) { HEX: 38 HEX: 32 } HEX: 66 2-operand-rm-sse ;
+: PMOVZXWD ( dest src -- ) { HEX: 38 HEX: 33 } HEX: 66 2-operand-rm-sse ;
+: PMOVZXWQ ( dest src -- ) { HEX: 38 HEX: 34 } HEX: 66 2-operand-rm-sse ;
+: PMOVZXDQ ( dest src -- ) { HEX: 38 HEX: 35 } HEX: 66 2-operand-rm-sse ;
+: PCMPGTQ ( dest src -- ) { HEX: 38 HEX: 37 } HEX: 66 2-operand-rm-sse ;
+: PMINSB ( dest src -- ) { HEX: 38 HEX: 38 } HEX: 66 2-operand-rm-sse ;
+: PMINSD ( dest src -- ) { HEX: 38 HEX: 39 } HEX: 66 2-operand-rm-sse ;
+: PMINUW ( dest src -- ) { HEX: 38 HEX: 3a } HEX: 66 2-operand-rm-sse ;
+: PMINUD ( dest src -- ) { HEX: 38 HEX: 3b } HEX: 66 2-operand-rm-sse ;
+: PMAXSB ( dest src -- ) { HEX: 38 HEX: 3c } HEX: 66 2-operand-rm-sse ;
+: PMAXSD ( dest src -- ) { HEX: 38 HEX: 3d } HEX: 66 2-operand-rm-sse ;
+: PMAXUW ( dest src -- ) { HEX: 38 HEX: 3e } HEX: 66 2-operand-rm-sse ;
+: PMAXUD ( dest src -- ) { HEX: 38 HEX: 3f } HEX: 66 2-operand-rm-sse ;
+: PMULLD ( dest src -- ) { HEX: 38 HEX: 40 } HEX: 66 2-operand-rm-sse ;
+: PHMINPOSUW ( dest src -- ) { HEX: 38 HEX: 41 } HEX: 66 2-operand-rm-sse ;
+: CRC32B ( dest src -- ) { HEX: 38 HEX: f0 } HEX: f2 2-operand-rm-sse ;
+: CRC32 ( dest src -- ) { HEX: 38 HEX: f1 } HEX: f2 2-operand-rm-sse ;
+
+: ROUNDPS ( dest src imm -- ) { HEX: 3a HEX: 08 } HEX: 66 3-operand-rm-sse ;
+: ROUNDPD ( dest src imm -- ) { HEX: 3a HEX: 09 } HEX: 66 3-operand-rm-sse ;
+: ROUNDSS ( dest src imm -- ) { HEX: 3a HEX: 0a } HEX: 66 3-operand-rm-sse ;
+: ROUNDSD ( dest src imm -- ) { HEX: 3a HEX: 0b } HEX: 66 3-operand-rm-sse ;
+: BLENDPS ( dest src imm -- ) { HEX: 3a HEX: 0c } HEX: 66 3-operand-rm-sse ;
+: BLENDPD ( dest src imm -- ) { HEX: 3a HEX: 0d } HEX: 66 3-operand-rm-sse ;
+: PBLENDW ( dest src imm -- ) { HEX: 3a HEX: 0e } HEX: 66 3-operand-rm-sse ;
+: PALIGNR ( dest src imm -- ) { HEX: 3a HEX: 0f } HEX: 66 3-operand-rm-sse ;
+
+: PEXTRB ( dest src imm -- ) { HEX: 3a HEX: 14 } HEX: 66 3-operand-mr-sse ;
+
+<PRIVATE
+: (PEXTRW-sse1) ( dest src imm -- ) HEX: c5 HEX: 66 3-operand-rm-sse ;
+: (PEXTRW-sse4) ( dest src imm -- ) { HEX: 3a HEX: 15 } HEX: 66 3-operand-mr-sse ;
PRIVATE>
-: MOVSS ( dest src -- ) HEX: 10 HEX: f3 2-operand-sse ;
-: MOVSD ( dest src -- ) HEX: 10 HEX: f2 2-operand-sse ;
-: ADDSD ( dest src -- ) HEX: 58 HEX: f2 2-operand-sse ;
-: MULSD ( dest src -- ) HEX: 59 HEX: f2 2-operand-sse ;
-: SUBSD ( dest src -- ) HEX: 5c HEX: f2 2-operand-sse ;
-: DIVSD ( dest src -- ) HEX: 5e HEX: f2 2-operand-sse ;
-: SQRTSD ( dest src -- ) HEX: 51 HEX: f2 2-operand-sse ;
-: UCOMISD ( dest src -- ) HEX: 2e HEX: 66 2-operand-sse ;
-: COMISD ( dest src -- ) HEX: 2f HEX: 66 2-operand-sse ;
-
-: CVTSS2SD ( dest src -- ) HEX: 5a HEX: f3 2-operand-sse ;
-: CVTSD2SS ( dest src -- ) HEX: 5a HEX: f2 2-operand-sse ;
-
-: CVTSI2SD ( dest src -- ) HEX: 2a HEX: f2 2-operand-int/sse ;
-: CVTSD2SI ( dest src -- ) HEX: 2d HEX: f2 2-operand-int/sse ;
-: CVTTSD2SI ( dest src -- ) HEX: 2c HEX: f2 2-operand-int/sse ;
+: PEXTRW ( dest src imm -- ) pick indirect? [ (PEXTRW-sse4) ] [ (PEXTRW-sse1) ] if ;
+: PEXTRD ( dest src imm -- ) { HEX: 3a HEX: 16 } HEX: 66 3-operand-mr-sse ;
+ALIAS: PEXTRQ PEXTRD
+: EXTRACTPS ( dest src imm -- ) { HEX: 3a HEX: 17 } HEX: 66 3-operand-mr-sse ;
+
+: PINSRB ( dest src imm -- ) { HEX: 3a HEX: 20 } HEX: 66 3-operand-rm-sse ;
+: INSERTPS ( dest src imm -- ) { HEX: 3a HEX: 21 } HEX: 66 3-operand-rm-sse ;
+: PINSRD ( dest src imm -- ) { HEX: 3a HEX: 22 } HEX: 66 3-operand-rm-sse ;
+ALIAS: PINSRQ PINSRD
+: DPPS ( dest src imm -- ) { HEX: 3a HEX: 40 } HEX: 66 3-operand-rm-sse ;
+: DPPD ( dest src imm -- ) { HEX: 3a HEX: 41 } HEX: 66 3-operand-rm-sse ;
+: MPSADBW ( dest src imm -- ) { HEX: 3a HEX: 42 } HEX: 66 3-operand-rm-sse ;
+: PCMPESTRM ( dest src imm -- ) { HEX: 3a HEX: 60 } HEX: 66 3-operand-rm-sse ;
+: PCMPESTRI ( dest src imm -- ) { HEX: 3a HEX: 61 } HEX: 66 3-operand-rm-sse ;
+: PCMPISTRM ( dest src imm -- ) { HEX: 3a HEX: 62 } HEX: 66 3-operand-rm-sse ;
+: PCMPISTRI ( dest src imm -- ) { HEX: 3a HEX: 63 } HEX: 66 3-operand-rm-sse ;
+
+: MOVMSKPS ( dest src -- ) HEX: 50 f 2-operand-int/sse ;
+: MOVMSKPD ( dest src -- ) HEX: 50 HEX: 66 2-operand-int/sse ;
+: SQRTPS ( dest src -- ) HEX: 51 f 2-operand-rm-sse ;
+: SQRTPD ( dest src -- ) HEX: 51 HEX: 66 2-operand-rm-sse ;
+: SQRTSD ( dest src -- ) HEX: 51 HEX: f2 2-operand-rm-sse ;
+: SQRTSS ( dest src -- ) HEX: 51 HEX: f3 2-operand-rm-sse ;
+: RSQRTPS ( dest src -- ) HEX: 52 f 2-operand-rm-sse ;
+: RSQRTSS ( dest src -- ) HEX: 52 HEX: f3 2-operand-rm-sse ;
+: RCPPS ( dest src -- ) HEX: 53 f 2-operand-rm-sse ;
+: RCPSS ( dest src -- ) HEX: 53 HEX: f3 2-operand-rm-sse ;
+: ANDPS ( dest src -- ) HEX: 54 f 2-operand-rm-sse ;
+: ANDPD ( dest src -- ) HEX: 54 HEX: 66 2-operand-rm-sse ;
+: ANDNPS ( dest src -- ) HEX: 55 f 2-operand-rm-sse ;
+: ANDNPD ( dest src -- ) HEX: 55 HEX: 66 2-operand-rm-sse ;
+: ORPS ( dest src -- ) HEX: 56 f 2-operand-rm-sse ;
+: ORPD ( dest src -- ) HEX: 56 HEX: 66 2-operand-rm-sse ;
+: XORPS ( dest src -- ) HEX: 57 f 2-operand-rm-sse ;
+: XORPD ( dest src -- ) HEX: 57 HEX: 66 2-operand-rm-sse ;
+: ADDPS ( dest src -- ) HEX: 58 f 2-operand-rm-sse ;
+: ADDPD ( dest src -- ) HEX: 58 HEX: 66 2-operand-rm-sse ;
+: ADDSD ( dest src -- ) HEX: 58 HEX: f2 2-operand-rm-sse ;
+: ADDSS ( dest src -- ) HEX: 58 HEX: f3 2-operand-rm-sse ;
+: MULPS ( dest src -- ) HEX: 59 f 2-operand-rm-sse ;
+: MULPD ( dest src -- ) HEX: 59 HEX: 66 2-operand-rm-sse ;
+: MULSD ( dest src -- ) HEX: 59 HEX: f2 2-operand-rm-sse ;
+: MULSS ( dest src -- ) HEX: 59 HEX: f3 2-operand-rm-sse ;
+: CVTPS2PD ( dest src -- ) HEX: 5a f 2-operand-rm-sse ;
+: CVTPD2PS ( dest src -- ) HEX: 5a HEX: 66 2-operand-rm-sse ;
+: CVTSD2SS ( dest src -- ) HEX: 5a HEX: f2 2-operand-rm-sse ;
+: CVTSS2SD ( dest src -- ) HEX: 5a HEX: f3 2-operand-rm-sse ;
+: CVTDQ2PS ( dest src -- ) HEX: 5b f 2-operand-rm-sse ;
+: CVTPS2DQ ( dest src -- ) HEX: 5b HEX: 66 2-operand-rm-sse ;
+: CVTTPS2DQ ( dest src -- ) HEX: 5b HEX: f3 2-operand-rm-sse ;
+: SUBPS ( dest src -- ) HEX: 5c f 2-operand-rm-sse ;
+: SUBPD ( dest src -- ) HEX: 5c HEX: 66 2-operand-rm-sse ;
+: SUBSD ( dest src -- ) HEX: 5c HEX: f2 2-operand-rm-sse ;
+: SUBSS ( dest src -- ) HEX: 5c HEX: f3 2-operand-rm-sse ;
+: MINPS ( dest src -- ) HEX: 5d f 2-operand-rm-sse ;
+: MINPD ( dest src -- ) HEX: 5d HEX: 66 2-operand-rm-sse ;
+: MINSD ( dest src -- ) HEX: 5d HEX: f2 2-operand-rm-sse ;
+: MINSS ( dest src -- ) HEX: 5d HEX: f3 2-operand-rm-sse ;
+: DIVPS ( dest src -- ) HEX: 5e f 2-operand-rm-sse ;
+: DIVPD ( dest src -- ) HEX: 5e HEX: 66 2-operand-rm-sse ;
+: DIVSD ( dest src -- ) HEX: 5e HEX: f2 2-operand-rm-sse ;
+: DIVSS ( dest src -- ) HEX: 5e HEX: f3 2-operand-rm-sse ;
+: MAXPS ( dest src -- ) HEX: 5f f 2-operand-rm-sse ;
+: MAXPD ( dest src -- ) HEX: 5f HEX: 66 2-operand-rm-sse ;
+: MAXSD ( dest src -- ) HEX: 5f HEX: f2 2-operand-rm-sse ;
+: MAXSS ( dest src -- ) HEX: 5f HEX: f3 2-operand-rm-sse ;
+: PUNPCKLQDQ ( dest src -- ) HEX: 6c HEX: 66 2-operand-rm-sse ;
+: PUNPCKHQDQ ( dest src -- ) HEX: 6d HEX: 66 2-operand-rm-sse ;
+
+: MOVDQA ( dest src -- ) { HEX: 6f HEX: 7f } HEX: 66 2-operand-rm-mr-sse ;
+: MOVDQU ( dest src -- ) { HEX: 6f HEX: 7f } HEX: f3 2-operand-rm-mr-sse ;
+
+: PSHUFD ( dest src imm -- ) HEX: 70 HEX: 66 3-operand-rm-sse ;
+: PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-rm-sse ;
+: PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-rm-sse ;
+: PSRLW ( dest imm -- ) BIN: 010 HEX: 71 HEX: 66 2-operand-sse-shift ;
+: PSRAW ( dest imm -- ) BIN: 100 HEX: 71 HEX: 66 2-operand-sse-shift ;
+: PSLLW ( dest imm -- ) BIN: 110 HEX: 71 HEX: 66 2-operand-sse-shift ;
+: PSRLD ( dest imm -- ) BIN: 010 HEX: 72 HEX: 66 2-operand-sse-shift ;
+: PSRAD ( dest imm -- ) BIN: 100 HEX: 72 HEX: 66 2-operand-sse-shift ;
+: PSLLD ( dest imm -- ) BIN: 110 HEX: 72 HEX: 66 2-operand-sse-shift ;
+: PSRLQ ( dest imm -- ) BIN: 010 HEX: 73 HEX: 66 2-operand-sse-shift ;
+: PSRLDQ ( dest imm -- ) BIN: 011 HEX: 73 HEX: 66 2-operand-sse-shift ;
+: PSLLQ ( dest imm -- ) BIN: 110 HEX: 73 HEX: 66 2-operand-sse-shift ;
+: PSLLDQ ( dest imm -- ) BIN: 111 HEX: 73 HEX: 66 2-operand-sse-shift ;
+
+: PCMPEQB ( dest src -- ) HEX: 74 HEX: 66 2-operand-rm-sse ;
+: PCMPEQW ( dest src -- ) HEX: 75 HEX: 66 2-operand-rm-sse ;
+: PCMPEQD ( dest src -- ) HEX: 76 HEX: 66 2-operand-rm-sse ;
+: HADDPD ( dest src -- ) HEX: 7c HEX: 66 2-operand-rm-sse ;
+: HADDPS ( dest src -- ) HEX: 7c HEX: f2 2-operand-rm-sse ;
+: HSUBPD ( dest src -- ) HEX: 7d HEX: 66 2-operand-rm-sse ;
+: HSUBPS ( dest src -- ) HEX: 7d HEX: f2 2-operand-rm-sse ;
+
+: LDMXCSR ( src -- ) { BIN: 010 f { HEX: 0f HEX: ae } } 1-operand ;
+: STMXCSR ( dest -- ) { BIN: 011 f { HEX: 0f HEX: ae } } 1-operand ;
+: LFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 350 , ;
+: MFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 360 , ;
+: SFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 370 , ;
+
+: POPCNT ( dest src -- ) HEX: b8 HEX: f3 2-operand-rm-sse ;
+
+: CMPEQPS ( dest src -- ) 0 HEX: c2 f 2-operand-sse-cmp ;
+: CMPLTPS ( dest src -- ) 1 HEX: c2 f 2-operand-sse-cmp ;
+: CMPLEPS ( dest src -- ) 2 HEX: c2 f 2-operand-sse-cmp ;
+: CMPUNORDPS ( dest src -- ) 3 HEX: c2 f 2-operand-sse-cmp ;
+: CMPNEQPS ( dest src -- ) 4 HEX: c2 f 2-operand-sse-cmp ;
+: CMPNLTPS ( dest src -- ) 5 HEX: c2 f 2-operand-sse-cmp ;
+: CMPNLEPS ( dest src -- ) 6 HEX: c2 f 2-operand-sse-cmp ;
+: CMPORDPS ( dest src -- ) 7 HEX: c2 f 2-operand-sse-cmp ;
+
+: CMPEQPD ( dest src -- ) 0 HEX: c2 HEX: 66 2-operand-sse-cmp ;
+: CMPLTPD ( dest src -- ) 1 HEX: c2 HEX: 66 2-operand-sse-cmp ;
+: CMPLEPD ( dest src -- ) 2 HEX: c2 HEX: 66 2-operand-sse-cmp ;
+: CMPUNORDPD ( dest src -- ) 3 HEX: c2 HEX: 66 2-operand-sse-cmp ;
+: CMPNEQPD ( dest src -- ) 4 HEX: c2 HEX: 66 2-operand-sse-cmp ;
+: CMPNLTPD ( dest src -- ) 5 HEX: c2 HEX: 66 2-operand-sse-cmp ;
+: CMPNLEPD ( dest src -- ) 6 HEX: c2 HEX: 66 2-operand-sse-cmp ;
+: CMPORDPD ( dest src -- ) 7 HEX: c2 HEX: 66 2-operand-sse-cmp ;
+
+: CMPEQSD ( dest src -- ) 0 HEX: c2 HEX: f2 2-operand-sse-cmp ;
+: CMPLTSD ( dest src -- ) 1 HEX: c2 HEX: f2 2-operand-sse-cmp ;
+: CMPLESD ( dest src -- ) 2 HEX: c2 HEX: f2 2-operand-sse-cmp ;
+: CMPUNORDSD ( dest src -- ) 3 HEX: c2 HEX: f2 2-operand-sse-cmp ;
+: CMPNEQSD ( dest src -- ) 4 HEX: c2 HEX: f2 2-operand-sse-cmp ;
+: CMPNLTSD ( dest src -- ) 5 HEX: c2 HEX: f2 2-operand-sse-cmp ;
+: CMPNLESD ( dest src -- ) 6 HEX: c2 HEX: f2 2-operand-sse-cmp ;
+: CMPORDSD ( dest src -- ) 7 HEX: c2 HEX: f2 2-operand-sse-cmp ;
+
+: CMPEQSS ( dest src -- ) 0 HEX: c2 HEX: f3 2-operand-sse-cmp ;
+: CMPLTSS ( dest src -- ) 1 HEX: c2 HEX: f3 2-operand-sse-cmp ;
+: CMPLESS ( dest src -- ) 2 HEX: c2 HEX: f3 2-operand-sse-cmp ;
+: CMPUNORDSS ( dest src -- ) 3 HEX: c2 HEX: f3 2-operand-sse-cmp ;
+: CMPNEQSS ( dest src -- ) 4 HEX: c2 HEX: f3 2-operand-sse-cmp ;
+: CMPNLTSS ( dest src -- ) 5 HEX: c2 HEX: f3 2-operand-sse-cmp ;
+: CMPNLESS ( dest src -- ) 6 HEX: c2 HEX: f3 2-operand-sse-cmp ;
+: CMPORDSS ( dest src -- ) 7 HEX: c2 HEX: f3 2-operand-sse-cmp ;
+
+: MOVNTI ( dest src -- ) { HEX: 0f HEX: c3 } (2-operand) ;
+
+: PINSRW ( dest src imm -- ) HEX: c4 HEX: 66 3-operand-rm-sse ;
+: SHUFPS ( dest src imm -- ) HEX: c6 f 3-operand-rm-sse ;
+: SHUFPD ( dest src imm -- ) HEX: c6 HEX: 66 3-operand-rm-sse ;
+
+: ADDSUBPD ( dest src -- ) HEX: d0 HEX: 66 2-operand-rm-sse ;
+: ADDSUBPS ( dest src -- ) HEX: d0 HEX: f2 2-operand-rm-sse ;
+: PADDQ ( dest src -- ) HEX: d4 HEX: 66 2-operand-rm-sse ;
+: PMINUB ( dest src -- ) HEX: da HEX: 66 2-operand-rm-sse ;
+: PMAXUB ( dest src -- ) HEX: de HEX: 66 2-operand-rm-sse ;
+: PAVGB ( dest src -- ) HEX: e0 HEX: 66 2-operand-rm-sse ;
+: PAVGW ( dest src -- ) HEX: e3 HEX: 66 2-operand-rm-sse ;
+: PMULHUW ( dest src -- ) HEX: e4 HEX: 66 2-operand-rm-sse ;
+: CVTTPD2DQ ( dest src -- ) HEX: e6 HEX: 66 2-operand-rm-sse ;
+: CVTPD2DQ ( dest src -- ) HEX: e6 HEX: f2 2-operand-rm-sse ;
+: CVTDQ2PD ( dest src -- ) HEX: e6 HEX: f3 2-operand-rm-sse ;
+
+: MOVNTDQ ( dest src -- ) HEX: e7 HEX: 66 2-operand-mr-sse ;
+
+: PMINSW ( dest src -- ) HEX: ea HEX: 66 2-operand-rm-sse ;
+: PMAXSW ( dest src -- ) HEX: ee HEX: 66 2-operand-rm-sse ;
+: LDDQU ( dest src -- ) HEX: f0 HEX: f2 2-operand-rm-sse ;
+: PMULUDQ ( dest src -- ) HEX: f4 HEX: 66 2-operand-rm-sse ;
+: PSADBW ( dest src -- ) HEX: f6 HEX: 66 2-operand-rm-sse ;
+
+: MASKMOVDQU ( dest src -- ) HEX: f7 HEX: 66 2-operand-rm-sse ;
+
+: PSUBQ ( dest src -- ) HEX: fb HEX: 66 2-operand-rm-sse ;
+
+! x86-64 branch prediction hints
+
+: HWNT ( -- ) HEX: 2e , ; ! Hint branch Weakly Not Taken
+: HST ( -- ) HEX: 3e , ; ! Hint branch Strongly Taken
+
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 >>
HOOK: pic-tail-reg cpu ( -- reg )
-M: x86 %load-immediate MOV ;
+M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
M: x86 %set-slot ( src obj slot tag temp -- ) (%slot) swap MOV ;
M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
-M: x86 %add [+] LEA ;
-M: x86 %add-imm [+] LEA ;
+M: x86 %add 2over eq? [ nip ADD ] [ [+] LEA ] if ;
+M: x86 %add-imm 2over eq? [ nip ADD ] [ [+] LEA ] if ;
M: x86 %sub nip SUB ;
-M: x86 %sub-imm neg [+] LEA ;
+M: x86 %sub-imm 2over eq? [ nip SUB ] [ neg [+] LEA ] if ;
M: x86 %mul nip swap IMUL2 ;
M: x86 %mul-imm IMUL3 ;
M: x86 %and nip AND ;
: ?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
: representative? ( a disjoint-set -- ? )
dupd parent = ; inline
+PRIVATE>
+
GENERIC: representative ( a disjoint-set -- p )
M: disjoint-set representative
[ [ parent ] keep representative dup ] 2keep set-parent
] if ;
+<PRIVATE
+
: representatives ( a b disjoint-set -- r r )
[ representative ] curry bi@ ; inline
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 namespaces parser
-quotations sequences vocabs.parser words words.symbol ;
+USING: accessors arrays classes.mixin classes.parser classes.singleton
+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 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 [
\ push { { vector } { sbuf } } "specializer" set-word-prop
+\ last { { vector } } "specializer" set-word-prop
+
+\ set-last { { object vector } } "specializer" set-word-prop
+
\ push-all
{ { string sbuf } { array vector } { byte-array byte-vector } }
"specializer" set-word-prop
{ 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 ;
[ loading-bitmap>bytes >>bitmap ]
[ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
[ header>> height>> 0 < not >>upside-down? ]
- [ bitmap>component-order >>component-order ]
+ [ bitmap>component-order >>component-order ubyte-components >>component-type ]
} cleave ;
USING: images tools.test kernel accessors ;
IN: images.tests
-[ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA f B{
+[ B{ 57 57 57 255 } ] [ 1 1 T{ image f { 2 3 } RGBA ubyte-components f B{
0 0 0 0
0 0 0 0
0 0 0 0
57 57 57 255
0 0 0 0
0 0 0 0
-} ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA f B{
+} ] [ B{ 57 57 57 255 } 1 1 T{ image f { 2 3 } RGBA ubyte-components f B{
0 0 0 0
0 0 0 0
0 0 0 0
USING: combinators kernel accessors sequences math arrays ;
IN: images
-SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
-R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
+SINGLETONS:
+ A L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
+ INTENSITY DEPTH DEPTH-STENCIL R RG
+ ubyte-components ushort-components uint-components
+ half-components float-components
+ byte-integer-components ubyte-integer-components
+ short-integer-components ushort-integer-components
+ int-integer-components uint-integer-components
+ u-5-5-5-1-components u-5-6-5-components
+ u-10-10-10-2-components
+ u-24-components u-24-8-components
+ float-32-u-8-components
+ u-9-9-9-e5-components
+ float-11-11-10-components ;
-UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
+UNION: component-order
+ A L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
+ INTENSITY DEPTH DEPTH-STENCIL R RG ;
-: bytes-per-pixel ( component-order -- n )
+UNION: component-type
+ ubyte-components ushort-components uint-components
+ half-components float-components
+ byte-integer-components ubyte-integer-components
+ short-integer-components ushort-integer-components
+ int-integer-components uint-integer-components
+ u-5-5-5-1-components u-5-6-5-components
+ u-10-10-10-2-components
+ u-24-components u-24-8-components
+ float-32-u-8-components
+ u-9-9-9-e5-components
+ float-11-11-10-components ;
+
+UNION: unnormalized-integer-components
+ byte-integer-components ubyte-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
+ u-24-components u-24-8-components
+ float-32-u-8-components
+ u-9-9-9-e5-components
+ float-11-11-10-components ;
+
+UNION: alpha-channel BGRA RGBA ABGR ARGB LA A INTENSITY ;
+
+UNION: alpha-channel-precedes-colors ABGR ARGB XBGR XRGB ;
+
+TUPLE: image dim component-order component-type upside-down? bitmap ;
+
+: <image> ( -- image ) image new ; inline
+
+: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
+
+GENERIC: load-image* ( path class -- image )
+
+: bytes-per-component ( component-type -- n )
+ {
+ { ubyte-components [ 1 ] }
+ { ushort-components [ 2 ] }
+ { uint-components [ 4 ] }
+ { half-components [ 2 ] }
+ { float-components [ 4 ] }
+ { byte-integer-components [ 1 ] }
+ { ubyte-integer-components [ 1 ] }
+ { short-integer-components [ 2 ] }
+ { ushort-integer-components [ 2 ] }
+ { int-integer-components [ 4 ] }
+ { uint-integer-components [ 4 ] }
+ } case ;
+
+: bytes-per-packed-pixel ( component-type -- n )
+ {
+ { u-5-5-5-1-components [ 2 ] }
+ { u-5-6-5-components [ 2 ] }
+ { u-10-10-10-2-components [ 4 ] }
+ { u-24-components [ 4 ] }
+ { u-24-8-components [ 4 ] }
+ { u-9-9-9-e5-components [ 4 ] }
+ { float-11-11-10-components [ 4 ] }
+ { float-32-u-8-components [ 8 ] }
+ } case ;
+
+: component-count ( component-order -- n )
{
+ { A [ 1 ] }
{ L [ 1 ] }
{ LA [ 2 ] }
{ BGR [ 3 ] }
{ XRGB [ 4 ] }
{ BGRX [ 4 ] }
{ XBGR [ 4 ] }
- { R16G16B16 [ 6 ] }
- { R32G32B32 [ 12 ] }
- { R16G16B16A16 [ 8 ] }
- { R32G32B32A32 [ 16 ] }
+ { INTENSITY [ 1 ] }
+ { DEPTH [ 1 ] }
+ { DEPTH-STENCIL [ 1 ] }
+ { R [ 1 ] }
+ { RG [ 2 ] }
} case ;
-TUPLE: image dim component-order upside-down? bitmap ;
-
-: <image> ( -- image ) image new ; inline
-
-: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
+: (bytes-per-pixel) ( component-order component-type -- n )
+ dup packed-components?
+ [ nip bytes-per-packed-pixel ] [
+ [ component-count ] [ bytes-per-component ] bi* *
+ ] if ;
-GENERIC: load-image* ( path class -- image )
+: bytes-per-pixel ( image -- n )
+ [ component-order>> ] [ component-type>> ] bi (bytes-per-pixel) ;
<PRIVATE
: pixel@ ( x y image -- start end bitmap )
[ dim>> first * + ]
- [ component-order>> bytes-per-pixel [ * dup ] keep + ]
+ [ bytes-per-pixel [ * dup ] keep + ]
[ bitmap>> ] tri ;
: set-subseq ( new-value from to victim -- )
: setup-bitmap ( image -- )
dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
BGR >>component-order
+ ubyte-components >>component-type
f >>upside-down?
dup dim>> first2 * 3 * 0 <array> >>bitmap
drop ;
[ <image> ] dip {
[ png-image-bytes >>bitmap ]
[ [ width>> ] [ height>> ] bi 2array >>dim ]
- [ drop RGB >>component-order ]
+ [ drop RGB >>component-order ubyte-components >>component-type ]
} cleave ;
: decode-indexed-color ( loading-png -- loading-png )
<image> over matrix-dim >>dim\r
swap flip flatten\r
[ 128 * 128 + 0 max 255 min >fixnum ] map\r
- >byte-array >>bitmap L >>component-order ;\r
+ >byte-array >>bitmap L >>component-order ubyte-components >>component-type ;\r
\r
:: matrix-zoom ( m f -- m' )\r
m matrix-dim f v*n coord-matrix\r
[
{
{
- T{ image f { 2 2 } L f B{ 1 2 5 6 } }
- T{ image f { 2 2 } L f B{ 3 4 7 8 } }
+ T{ image f { 2 2 } L ubyte-components f B{ 1 2 5 6 } }
+ T{ image f { 2 2 } L ubyte-components f B{ 3 4 7 8 } }
}
{
- T{ image f { 2 2 } L f B{ 9 10 13 14 } }
- T{ image f { 2 2 } L f B{ 11 12 15 16 } }
+ T{ image f { 2 2 } L ubyte-components f B{ 9 10 13 14 } }
+ T{ image f { 2 2 } L ubyte-components f B{ 11 12 15 16 } }
}
}
] [
1 16 [a,b] >byte-array >>bitmap
{ 4 4 } >>dim
L >>component-order
+ ubyte-components >>component-type
{ 2 2 } tesselate
] unit-test
[
{
{
- T{ image f { 2 2 } L f B{ 1 2 4 5 } }
- T{ image f { 1 2 } L f B{ 3 6 } }
+ T{ image f { 2 2 } L ubyte-components f B{ 1 2 4 5 } }
+ T{ image f { 1 2 } L ubyte-components f B{ 3 6 } }
}
{
- T{ image f { 2 1 } L f B{ 7 8 } }
- T{ image f { 1 1 } L f B{ 9 } }
+ T{ image f { 2 1 } L ubyte-components f B{ 7 8 } }
+ T{ image f { 1 1 } L ubyte-components f B{ 9 } }
}
}
] [
1 9 [a,b] >byte-array >>bitmap
{ 3 3 } >>dim
L >>component-order
+ ubyte-components >>component-type
{ 2 2 } tesselate
-] unit-test
\ No newline at end of file
+] unit-test
'[ _ tesselate-columns ] map ;
: tile-width ( tile-bitmap original-image -- width )
- [ first length ] [ component-order>> bytes-per-pixel ] bi* /i ;
+ [ first length ] [ bytes-per-pixel ] bi* /i ;
: <tile-image> ( tile-bitmap original-image -- tile-image )
clone
[ [ over tile-width ] [ length ] bi 2array >>dim ] bi ;
:: tesselate ( image tess-dim -- image-grid )
- image component-order>> bytes-per-pixel :> bpp
+ image bytes-per-pixel :> bpp
image dim>> { bpp 1 } v* :> image-dim'
tess-dim { bpp 1 } v* :> tess-dim'
image bitmap>> image-dim' tess-dim' tesselate-bitmap
- [ [ image <tile-image> ] map ] map ;
\ No newline at end of file
+ [ [ image <tile-image> ] map ] map ;
[ unknown-component-order ]
} case >>bitmap ;
-: ifd-component-order ( ifd -- byte-order )
+: ifd-component-order ( ifd -- component-order component-type )
bits-per-sample find-tag {
- { { 32 32 32 32 } [ R32G32B32A32 ] }
- { { 32 32 32 } [ R32G32B32 ] }
- { { 16 16 16 16 } [ R16G16B16A16 ] }
- { { 16 16 16 } [ R16G16B16 ] }
- { { 8 8 8 8 } [ RGBA ] }
- { { 8 8 8 } [ RGB ] }
- { 8 [ LA ] }
+ { { 32 32 32 32 } [ RGBA float-components ] }
+ { { 32 32 32 } [ RGB float-components ] }
+ { { 16 16 16 16 } [ RGBA ushort-components ] }
+ { { 16 16 16 } [ RGB ushort-components ] }
+ { { 8 8 8 8 } [ RGBA ubyte-components ] }
+ { { 8 8 8 } [ RGB ubyte-components ] }
+ { 8 [ LA ubyte-components ] }
[ unknown-component-order ]
} case ;
: ifd>image ( ifd -- image )
[ <image> ] dip {
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array >>dim ]
- [ ifd-component-order >>component-order ]
+ [ ifd-component-order [ >>component-order ] [ >>component-type ] bi* ]
[ bitmap>> >>bitmap ]
} cleave ;
{ [ os winnt? ] [ "io.launcher.windows.nt" require ] }
[ ]
} cond
-
-: run-desc ( desc -- result ) ascii <process-reader> f swap stream-read-until drop ;
! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel math sequences accessors
-math.bits sequences.private words namespaces macros
-hints combinators fry io.binary combinators.smart ;
+USING: arrays assocs combinators combinators.smart fry kernel
+macros math math.bits sequences sequences.private words ;
IN: math.bitwise
! utilities
: bit-count ( x -- n )
dup 0 < [ bitnot ] when (bit-count) ; inline
-! Signed byte array to integer conversion
-: signed-le> ( bytes -- x )
- [ le> ] [ length 8 * 1 - on-bits ] bi
- 2dup > [ bitnot bitor ] [ drop ] if ;
-
-: signed-be> ( bytes -- x )
- <reversed> signed-le> ;
-
: >signed ( x n -- y )
2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
! 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 ;
HELP: sieve
{ $values { "n" "the greatest odd number to consider" } { "arr" "a bit array" } }
-{ $description "Return a bit array containing a primality bit for every odd number between 3 and " { $snippet "n" } " (inclusive). " { $snippet ">index" } " can be used to retrieve the index of an odd number to be tested." } ;
+{ $description "Apply Eratostene sieve up to " { $snippet "n" } ". Primality can then be tested using " { $link sieve } "." } ;
-HELP: >index
-{ $values { "n" "an odd number" } { "i" "the corresponding index" } }
-{ $description "Retrieve the index corresponding to the odd number on the stack." } ;
-
-{ sieve >index } related-words
+HELP: marked-prime?
+{ $values { "n" "an integer" } { "arr" "a byte array returned by " { $link sieve } } { "?" "a boolean" } }
+{ $description "Check whether a number between 3 and the limit given to " { $link sieve } " has been marked as a prime number."} ;
-USING: bit-arrays math.primes.erato tools.test ;
+USING: byte-arrays math math.bitwise math.primes.erato sequences tools.test ;
-[ ?{ t t t f t t f t t f t f f t } ] [ 29 sieve ] unit-test
+[ B{ 255 251 247 126 } ] [ 100 sieve ] unit-test
+[ 1 100 sieve marked-prime? ] [ bounds-error? ] must-fail-with
+[ 120 100 sieve marked-prime? ] [ bounds-error? ] must-fail-with
+[ f ] [ 119 100 sieve marked-prime? ] unit-test
+[ t ] [ 113 100 sieve marked-prime? ] unit-test
+
+! There are 25997 primes below 300000. 1 must be removed and 3 5 7 added.
+[ 25997 ] [ 299999 sieve [ bit-count ] sigma 2 + ] unit-test
\ No newline at end of file
! Copyright (C) 2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: bit-arrays kernel math math.functions math.ranges sequences ;
+USING: arrays byte-arrays kernel math math.bitwise math.functions math.order
+math.ranges sequences sequences.private ;
IN: math.primes.erato
-: >index ( n -- i )
- 3 - 2 /i ; inline
+<PRIVATE
-: index> ( i -- n )
- 2 * 3 + ; inline
+CONSTANT: masks B{ 0 128 0 0 0 0 0 64 0 0 0 32 0 16 0 0 0 8 0 4 0 0 0 2 0 0 0 0 0 1 }
-: mark-multiples ( i arr -- )
- [ index> [ sq >index ] keep ] dip
- [ length 1 - swap <range> f swap ] keep
- [ set-nth ] curry with each ;
+: bit-pos ( n -- byte/f mask/f )
+ 30 /mod masks nth-unsafe dup zero? [ 2drop f f ] when ;
-: maybe-mark-multiples ( i arr -- )
- 2dup nth [ mark-multiples ] [ 2drop ] if ;
+: marked-unsafe? ( n arr -- ? )
+ [ bit-pos ] dip swap [ [ nth-unsafe ] [ bitand zero? not ] bi* ] [ 2drop f ] if* ;
-: init-sieve ( n -- arr )
- >index 1 + <bit-array> dup set-bits ;
+: unmark ( n arr -- )
+ [ bit-pos swap ] dip
+ over [ [ swap unmask ] change-nth-unsafe ] [ 3drop ] if ;
+
+: upper-bound ( arr -- n ) length 30 * 1 - ;
+
+: unmark-multiples ( i arr -- )
+ 2dup marked-unsafe? [
+ [ [ dup sq ] [ upper-bound ] bi* rot <range> ] keep
+ [ unmark ] curry each
+ ] [
+ 2drop
+ ] if ;
+
+: init-sieve ( n -- arr ) 29 + 30 /i 255 <array> >byte-array ;
+
+PRIVATE>
: sieve ( n -- arr )
- [ init-sieve ] [ sqrt >index [0,b] ] bi
- over [ maybe-mark-multiples ] curry each ; foldable
+ init-sieve [ 2 swap upper-bound sqrt [a,b] ] keep
+ [ [ unmark-multiples ] curry each ] keep ;
+
+: marked-prime? ( n arr -- ? )
+ 2dup upper-bound 2 swap between? [ bounds-error ] unless
+ over { 2 3 5 } member? [ 2drop t ] [ marked-unsafe? ] if ;
\ No newline at end of file
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 ;
-USING: arrays math math.primes math.primes.miller-rabin
-tools.test ;
+USING: arrays kernel math math.primes math.primes.miller-rabin
+sequences tools.test ;
IN: math.primes.tests
{ 1237 } [ 1234 next-prime ] unit-test
{ { 4999963 4999999 5000011 5000077 5000081 } }
[ 4999962 5000082 primes-between >array ] unit-test
+{ { 8999981 8999993 9000011 9000041 } }
+[ 8999980 9000045 primes-between >array ] unit-test
+
[ 2 ] [ 1 next-prime ] unit-test
[ 3 ] [ 2 next-prime ] unit-test
[ 5 ] [ 3 next-prime ] unit-test
[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
[ 49 ] [ 50 random-prime log2 ] unit-test
+
+[ t ] [ 5000077 dup find-relative-prime coprime? ] unit-test
+
+[ 5 t { 14 14 14 14 14 } ]
+[ 5 15 unique-primes [ length ] [ [ prime? ] all? ] [ [ log2 ] map ] tri ] unit-test
! Copyright (C) 2007-2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math math.bitwise math.functions
-math.order math.primes.erato math.primes.miller-rabin
-math.ranges random sequences sets fry ;
+USING: combinators combinators.short-circuit fry kernel math
+math.bitwise math.functions math.order math.primes.erato
+math.primes.erato.private math.primes.miller-rabin math.ranges
+literals random sequences sets vectors ;
IN: math.primes
<PRIVATE
-: look-in-bitmap ( n -- ? ) >index 4999999 sieve nth ;
+: look-in-bitmap ( n -- ? ) $[ 8999999 sieve ] marked-unsafe? ; inline
-: really-prime? ( n -- ? )
- dup 5000000 < [ look-in-bitmap ] [ miller-rabin ] if ; foldable
+: (prime?) ( n -- ? )
+ dup 8999999 <= [ look-in-bitmap ] [ miller-rabin ] if ;
+
+! In order not to reallocate large vectors, we compute the upper bound
+! of the number of primes in a given interval. We use a double inequality given
+! by Pierre Dusart in http://www.ams.org/mathscinet-getitem?mr=99d:11133
+! for x > 598. Under this limit, we know that there are at most 108 primes.
+: upper-pi ( x -- y )
+ dup log [ / ] [ 1.2762 swap / 1 + ] bi * ceiling ;
+
+: lower-pi ( x -- y )
+ dup log [ / ] [ 0.992 swap / 1 + ] bi * floor ;
+
+: <primes-vector> ( low high -- vector )
+ swap [ [ upper-pi ] [ lower-pi ] bi* - >integer
+ 108 max 10000 min <vector> ] keep
+ 3 < [ [ 2 swap push ] keep ] when ;
+
+: simple? ( n -- ? ) { [ even? ] [ 3 mod 0 = ] [ 5 mod 0 = ] } 1|| ;
PRIVATE>
: prime? ( n -- ? )
{
- { [ dup 2 < ] [ drop f ] }
- { [ dup even? ] [ 2 = ] }
- [ really-prime? ]
+ { [ dup 7 < ] [ { 2 3 5 } member? ] }
+ { [ dup simple? ] [ drop f ] }
+ [ (prime?) ]
} cond ; foldable
: next-prime ( n -- p )
dup 2 < [
drop 2
] [
- next-odd [ dup really-prime? ] [ 2 + ] until
+ next-odd [ dup prime? ] [ 2 + ] until
] if ; foldable
: primes-between ( low high -- seq )
- [ dup 3 max dup even? [ 1 + ] when ] dip
- 2 <range> [ prime? ] filter
- swap 3 < [ 2 prefix ] when ;
+ [ [ 3 max dup even? [ 1 + ] when ] dip 2 <range> ]
+ [ <primes-vector> ] 2bi
+ [ '[ [ prime? ] _ push-if ] each ] keep clone ;
: primes-upto ( n -- seq ) 2 swap primes-between ;
: unique-primes ( n numbits -- seq )
2dup 2^ estimated-primes > [ too-few-primes ] when
- 2dup '[ _ random-prime ] replicate
+ 2dup [ random-prime ] curry replicate
dup all-unique? [ 2nip ] [ drop unique-primes ] if ;
[ { 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 ;
HELP: has-gl-extensions?
{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
-{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
+{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } ". Elements of " { $snippet "extensions" } " can be sequences, in which case true will be returned if any one of the extensions in the subsequence are available." }
+{ $examples "Testing for framebuffer object and pixel buffer support:"
+ { $code <" {
+ { "GL_EXT_framebuffer_object" "GL_ARB_framebuffer_object" }
+ "GL_ARB_pixel_buffer_object"
+} has-gl-extensions? "> }
+} ;
HELP: has-gl-version-or-extensions?
{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } { "?" "a boolean" } }
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: opengl.capabilities tools.test ;
+IN: opengl.capabilities.tests
+
+CONSTANT: test-extensions
+ {
+ "GL_ARB_vent_core_frogblast"
+ "GL_EXT_resonance_cascade"
+ "GL_EXT_slipgate"
+ }
+
+[ t ]
+[ "GL_ARB_vent_core_frogblast" test-extensions (has-extension?) ] unit-test
+
+[ f ]
+[ "GL_ARB_wallhack" test-extensions (has-extension?) ] unit-test
+
+[ t ] [
+ { "GL_EXT_dimensional_portal" "GL_EXT_slipgate" }
+ test-extensions (has-extension?)
+] unit-test
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces make sequences splitting opengl.gl
-continuations math.parser math arrays sets math.order fry ;
+continuations math.parser math arrays sets strings math.order fry ;
IN: opengl.capabilities
: (require-gl) ( thing require-quot make-error-quot -- )
[ dupd call [ drop ] ] dip '[ _ " " make throw ] if ; inline
+: (has-extension?) ( query-extension(s) available-extensions -- ? )
+ over string? [ member? ] [ [ member? ] curry any? ] if ;
+
: gl-extensions ( -- seq )
GL_EXTENSIONS glGetString " " split ;
: has-gl-extensions? ( extensions -- ? )
- gl-extensions swap [ over member? ] all? nip ;
+ gl-extensions [ (has-extension?) ] curry all? ;
: (make-gl-extensions-error) ( required-extensions -- )
gl-extensions diff
"Required OpenGL extensions not supported:\n" %
--- /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
HELP: gen-framebuffer
{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ;
+{ $description "Wrapper for " { $link glGenFramebuffers } " to handle the common case of generating a single framebuffer ID." } ;
HELP: gen-renderbuffer
{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ;
+{ $description "Wrapper for " { $link glGenRenderbuffers } " to handle the common case of generating a single render buffer ID." } ;
HELP: delete-framebuffer
{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ;
+{ $description "Wrapper for " { $link glDeleteFramebuffers } " to handle the common case of deleting a single framebuffer ID." } ;
HELP: delete-renderbuffer
{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ;
+{ $description "Wrapper for " { $link glDeleteRenderbuffers } " to handle the common case of deleting a single render buffer ID." } ;
{ gen-framebuffer delete-framebuffer } related-words
{ gen-renderbuffer delete-renderbuffer } related-words
HELP: framebuffer-incomplete?
{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } }
-{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ;
+{ $description "Checks the framebuffer currently bound by " { $link glBindFramebuffer } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ;
HELP: check-framebuffer
-{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ;
+{ $description "Checks the framebuffer currently bound by " { $link glBindFramebuffer } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ;
HELP: with-framebuffer
{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } }
-{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ;
+{ $description "Binds framebuffer " { $snippet "id" } " for drawing in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ;
-ABOUT: "gl-utilities"
\ No newline at end of file
+ABOUT: "gl-utilities"
IN: opengl.framebuffers
: gen-framebuffer ( -- id )
- [ glGenFramebuffersEXT ] (gen-gl-object) ;
+ [ glGenFramebuffers ] (gen-gl-object) ;
: gen-renderbuffer ( -- id )
- [ glGenRenderbuffersEXT ] (gen-gl-object) ;
+ [ glGenRenderbuffers ] (gen-gl-object) ;
: delete-framebuffer ( id -- )
- [ glDeleteFramebuffersEXT ] (delete-gl-object) ;
+ [ glDeleteFramebuffers ] (delete-gl-object) ;
: delete-renderbuffer ( id -- )
- [ glDeleteRenderbuffersEXT ] (delete-gl-object) ;
+ [ glDeleteRenderbuffers ] (delete-gl-object) ;
: framebuffer-incomplete? ( -- status/f )
- GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
- dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ;
+ GL_DRAW_FRAMEBUFFER glCheckFramebufferStatus
+ dup GL_FRAMEBUFFER_COMPLETE = f rot ? ;
: framebuffer-error ( status -- * )
{
- { GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] }
- { GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] }
+ { GL_FRAMEBUFFER_COMPLETE [ "framebuffer complete" ] }
+ { GL_FRAMEBUFFER_UNSUPPORTED [ "framebuffer configuration unsupported" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT [ "framebuffer incomplete (incomplete attachment)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT [ "framebuffer incomplete (missing attachment)" ] }
{ GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] }
{ GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE_EXT [ "framebuffer incomplete (multisample counts don't match)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER [ "framebuffer incomplete (read buffer has no attachment)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE [ "framebuffer incomplete (multisample counts don't match)" ] }
[ drop gl-error "unknown framebuffer error" ]
} case throw ;
framebuffer-incomplete? [ framebuffer-error ] when* ;
: with-framebuffer ( id quot -- )
- [ GL_FRAMEBUFFER_EXT swap glBindFramebufferEXT ] dip
- [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline
+ [ GL_DRAW_FRAMEBUFFER swap glBindFramebuffer ] dip
+ [ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer ] [ ] cleanup ; inline
: with-draw-read-framebuffers ( draw-id read-id quot -- )
[
- [ GL_DRAW_FRAMEBUFFER_EXT swap glBindFramebufferEXT ]
- [ GL_READ_FRAMEBUFFER_EXT swap glBindFramebufferEXT ] bi*
+ [ GL_DRAW_FRAMEBUFFER swap glBindFramebuffer ]
+ [ GL_READ_FRAMEBUFFER swap glBindFramebuffer ] bi*
] dip
[
- GL_DRAW_FRAMEBUFFER_EXT 0 glBindFramebufferEXT
- GL_READ_FRAMEBUFFER_EXT 0 glBindFramebufferEXT
+ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer
+ GL_READ_FRAMEBUFFER 0 glBindFramebuffer
] [ ] cleanup ; inline
: framebuffer-attachment ( attachment -- id )
- GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT
- 0 <uint> [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ;
+ GL_FRAMEBUFFER swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME
+ 0 <uint> [ glGetFramebufferAttachmentParameteriv ] keep *uint ;
CONSTANT: GL_NONE HEX: 0
CONSTANT: GL_LEFT HEX: 0406
CONSTANT: GL_RIGHT HEX: 0407
-
+CONSTANT: GL_FRONT_LEFT HEX: 0400
CONSTANT: GL_FRONT_RIGHT HEX: 0401
CONSTANT: GL_BACK_LEFT HEX: 0402
CONSTANT: GL_BACK_RIGHT HEX: 0403
CONSTANT: GL_RGB HEX: 1907
CONSTANT: GL_RGBA HEX: 1908
-! GL_BGRA_ext: http://www.opengl.org/registry/specs/EXT/bgra.txt
-CONSTANT: GL_BGR_EXT HEX: 80E0
-CONSTANT: GL_BGRA_EXT HEX: 80E1
-
! Implementation limits
CONSTANT: GL_MAX_LIST_NESTING HEX: 0B31
CONSTANT: GL_MAX_ATTRIB_STACK_DEPTH HEX: 0D35
GL-FUNCTION: void glTexSubImage3D { glTexSubImage3DEXT } ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLint zoffset, GLsizei width, GLsizei height, GLsizei depth, GLenum format, GLenum type, GLvoid* pixels ) ;
+! GL_ARB_imaging
+
+
+CONSTANT: GL_CONSTANT_COLOR HEX: 8001
+CONSTANT: GL_ONE_MINUS_CONSTANT_COLOR HEX: 8002
+CONSTANT: GL_CONSTANT_ALPHA HEX: 8003
+CONSTANT: GL_ONE_MINUS_CONSTANT_ALPHA HEX: 8004
+CONSTANT: GL_BLEND_COLOR HEX: 8005
+CONSTANT: GL_FUNC_ADD HEX: 8006
+CONSTANT: GL_MIN HEX: 8007
+CONSTANT: GL_MAX HEX: 8008
+CONSTANT: GL_BLEND_EQUATION HEX: 8009
+CONSTANT: GL_FUNC_SUBTRACT HEX: 800A
+CONSTANT: GL_FUNC_REVERSE_SUBTRACT HEX: 800B
+
+
! OpenGL 1.3
GL-FUNCTION: void glMultiDrawElements { glMultiDrawElementsEXT } ( GLenum mode, GLsizei* count, GLenum type, GLvoid** indices, GLsizei primcount ) ;
GL-FUNCTION: void glPointParameterf { glPointParameterfARB } ( GLenum pname, GLfloat param ) ;
GL-FUNCTION: void glPointParameterfv { glPointParameterfvARB } ( GLenum pname, GLfloat* params ) ;
+GL-FUNCTION: void glPointParameteri { glPointParameteriARB } ( GLenum pname, GLint param ) ;
+GL-FUNCTION: void glPointParameteriv { glPointParameterivARB } ( GLenum pname, GLint* params ) ;
GL-FUNCTION: void glSecondaryColor3b { glSecondaryColor3bEXT } ( GLbyte red, GLbyte green, GLbyte blue ) ;
GL-FUNCTION: void glSecondaryColor3bv { glSecondaryColor3bvEXT } ( GLbyte* v ) ;
GL-FUNCTION: void glSecondaryColor3d { glSecondaryColor3dEXT } ( GLdouble red, GLdouble green, GLdouble blue ) ;
CONSTANT: GL_STENCIL_BACK_REF HEX: 8CA3
CONSTANT: GL_STENCIL_BACK_VALUE_MASK HEX: 8CA4
CONSTANT: GL_STENCIL_BACK_WRITEMASK HEX: 8CA5
-CONSTANT: GL_BLEND_EQUATION HEX: 8009
ALIAS: GL_BLEND_EQUATION_RGB GL_BLEND_EQUATION
TYPEDEF: char GLchar
CONSTANT: GL_COMPRESSED_SRGB_ALPHA HEX: 8C49
CONSTANT: GL_COMPRESSED_SLUMINANCE HEX: 8C4A
CONSTANT: GL_COMPRESSED_SLUMINANCE_ALPHA HEX: 8C4B
+CONSTANT: GL_FLOAT_MAT2x3 HEX: 8B65
+CONSTANT: GL_FLOAT_MAT2x4 HEX: 8B66
+CONSTANT: GL_FLOAT_MAT3x2 HEX: 8B67
+CONSTANT: GL_FLOAT_MAT3x4 HEX: 8B68
+CONSTANT: GL_FLOAT_MAT4x2 HEX: 8B69
+CONSTANT: GL_FLOAT_MAT4x3 HEX: 8B6A
GL-FUNCTION: void glUniformMatrix2x3fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix2x4fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
GL-FUNCTION: void glUniformMatrix4x3fv { } ( GLint location, GLsizei count, GLboolean transpose, GLfloat* value ) ;
-! GL_EXT_framebuffer_object
-
-
-CONSTANT: GL_INVALID_FRAMEBUFFER_OPERATION_EXT HEX: 0506
-CONSTANT: GL_MAX_RENDERBUFFER_SIZE_EXT HEX: 84E8
-CONSTANT: GL_FRAMEBUFFER_BINDING_EXT HEX: 8CA6
-CONSTANT: GL_RENDERBUFFER_BINDING_EXT HEX: 8CA7
-CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE_EXT HEX: 8CD0
-CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT HEX: 8CD1
-CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL_EXT HEX: 8CD2
-CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE_EXT HEX: 8CD3
-CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_3D_ZOFFSET_EXT HEX: 8CD4
-CONSTANT: GL_FRAMEBUFFER_COMPLETE_EXT HEX: 8CD5
-CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT HEX: 8CD6
-CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT HEX: 8CD7
-CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT HEX: 8CD9
-CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT HEX: 8CDA
-CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT HEX: 8CDB
-CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT HEX: 8CDC
-CONSTANT: GL_FRAMEBUFFER_UNSUPPORTED_EXT HEX: 8CDD
-CONSTANT: GL_MAX_COLOR_ATTACHMENTS_EXT HEX: 8CDF
-CONSTANT: GL_COLOR_ATTACHMENT0_EXT HEX: 8CE0
-CONSTANT: GL_COLOR_ATTACHMENT1_EXT HEX: 8CE1
-CONSTANT: GL_COLOR_ATTACHMENT2_EXT HEX: 8CE2
-CONSTANT: GL_COLOR_ATTACHMENT3_EXT HEX: 8CE3
-CONSTANT: GL_COLOR_ATTACHMENT4_EXT HEX: 8CE4
-CONSTANT: GL_COLOR_ATTACHMENT5_EXT HEX: 8CE5
-CONSTANT: GL_COLOR_ATTACHMENT6_EXT HEX: 8CE6
-CONSTANT: GL_COLOR_ATTACHMENT7_EXT HEX: 8CE7
-CONSTANT: GL_COLOR_ATTACHMENT8_EXT HEX: 8CE8
-CONSTANT: GL_COLOR_ATTACHMENT9_EXT HEX: 8CE9
-CONSTANT: GL_COLOR_ATTACHMENT10_EXT HEX: 8CEA
-CONSTANT: GL_COLOR_ATTACHMENT11_EXT HEX: 8CEB
-CONSTANT: GL_COLOR_ATTACHMENT12_EXT HEX: 8CEC
-CONSTANT: GL_COLOR_ATTACHMENT13_EXT HEX: 8CED
-CONSTANT: GL_COLOR_ATTACHMENT14_EXT HEX: 8CEE
-CONSTANT: GL_COLOR_ATTACHMENT15_EXT HEX: 8CEF
-CONSTANT: GL_DEPTH_ATTACHMENT_EXT HEX: 8D00
-CONSTANT: GL_STENCIL_ATTACHMENT_EXT HEX: 8D20
-CONSTANT: GL_FRAMEBUFFER_EXT HEX: 8D40
-CONSTANT: GL_RENDERBUFFER_EXT HEX: 8D41
-CONSTANT: GL_RENDERBUFFER_WIDTH_EXT HEX: 8D42
-CONSTANT: GL_RENDERBUFFER_HEIGHT_EXT HEX: 8D43
-CONSTANT: GL_RENDERBUFFER_INTERNAL_FORMAT_EXT HEX: 8D44
-CONSTANT: GL_STENCIL_INDEX1_EXT HEX: 8D46
-CONSTANT: GL_STENCIL_INDEX4_EXT HEX: 8D47
-CONSTANT: GL_STENCIL_INDEX8_EXT HEX: 8D48
-CONSTANT: GL_STENCIL_INDEX16_EXT HEX: 8D49
-CONSTANT: GL_RENDERBUFFER_RED_SIZE_EXT HEX: 8D50
-CONSTANT: GL_RENDERBUFFER_GREEN_SIZE_EXT HEX: 8D51
-CONSTANT: GL_RENDERBUFFER_BLUE_SIZE_EXT HEX: 8D52
-CONSTANT: GL_RENDERBUFFER_ALPHA_SIZE_EXT HEX: 8D53
-CONSTANT: GL_RENDERBUFFER_DEPTH_SIZE_EXT HEX: 8D54
-CONSTANT: GL_RENDERBUFFER_STENCIL_SIZE_EXT HEX: 8D55
-
-GL-FUNCTION: void glBindFramebufferEXT { } ( GLenum target, GLuint framebuffer ) ;
-GL-FUNCTION: void glBindRenderbufferEXT { } ( GLenum target, GLuint renderbuffer ) ;
-GL-FUNCTION: GLenum glCheckFramebufferStatusEXT { } ( GLenum target ) ;
-GL-FUNCTION: void glDeleteFramebuffersEXT { } ( GLsizei n, GLuint* framebuffers ) ;
-GL-FUNCTION: void glDeleteRenderbuffersEXT { } ( GLsizei n, GLuint* renderbuffers ) ;
-GL-FUNCTION: void glFramebufferRenderbufferEXT { } ( GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer ) ;
-GL-FUNCTION: void glFramebufferTexture1DEXT { } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ;
-GL-FUNCTION: void glFramebufferTexture2DEXT { } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ;
-GL-FUNCTION: void glFramebufferTexture3DEXT { } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level, GLint zoffset ) ;
-GL-FUNCTION: void glGenFramebuffersEXT { } ( GLsizei n, GLuint* framebuffers ) ;
-GL-FUNCTION: void glGenRenderbuffersEXT { } ( GLsizei n, GLuint* renderbuffers ) ;
-GL-FUNCTION: void glGenerateMipmapEXT { } ( GLenum target ) ;
-GL-FUNCTION: void glGetFramebufferAttachmentParameterivEXT { } ( GLenum target, GLenum attachment, GLenum pname, GLint* params ) ;
-GL-FUNCTION: void glGetRenderbufferParameterivEXT { } ( GLenum target, GLenum pname, GLint* params ) ;
-GL-FUNCTION: GLboolean glIsFramebufferEXT { } ( GLuint framebuffer ) ;
-GL-FUNCTION: GLboolean glIsRenderbufferEXT { } ( GLuint renderbuffer ) ;
-GL-FUNCTION: void glRenderbufferStorageEXT { } ( GLenum target, GLenum internalformat, GLsizei width, GLsizei height ) ;
-
-
-! GL_EXT_framebuffer_blit
-
-
-GL-FUNCTION: void glBlitFramebufferEXT { } ( GLint srcX0, GLint srcY0, GLint srcX1, GLint srcY1,
+! OpenGL 3.0
+
+
+TYPEDEF: ushort GLhalf
+
+CONSTANT: GL_VERTEX_ATTRIB_ARRAY_INTEGER HEX: 88FD
+CONSTANT: GL_SAMPLER_CUBE_SHADOW HEX: 8DC5
+CONSTANT: GL_UNSIGNED_INT_VEC2 HEX: 8DC6
+CONSTANT: GL_UNSIGNED_INT_VEC3 HEX: 8DC7
+CONSTANT: GL_UNSIGNED_INT_VEC4 HEX: 8DC8
+CONSTANT: GL_INT_SAMPLER_1D HEX: 8DC9
+CONSTANT: GL_INT_SAMPLER_2D HEX: 8DCA
+CONSTANT: GL_INT_SAMPLER_3D HEX: 8DCB
+CONSTANT: GL_INT_SAMPLER_CUBE HEX: 8DCC
+CONSTANT: GL_INT_SAMPLER_2D_RECT HEX: 8DCD
+CONSTANT: GL_INT_SAMPLER_1D_ARRAY HEX: 8DCE
+CONSTANT: GL_INT_SAMPLER_2D_ARRAY HEX: 8DCF
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_1D HEX: 8DD1
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D HEX: 8DD2
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_3D HEX: 8DD3
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_CUBE HEX: 8DD4
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_RECT HEX: 8DD5
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_1D_ARRAY HEX: 8DD6
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_ARRAY HEX: 8DD7
+CONSTANT: GL_MIN_PROGRAM_TEXEL_OFFSET HEX: 8904
+CONSTANT: GL_MAX_PROGRAM_TEXEL_OFFSET HEX: 8905
+
+CONSTANT: GL_RGBA32F HEX: 8814
+CONSTANT: GL_RGB32F HEX: 8815
+CONSTANT: GL_RGBA16F HEX: 881A
+CONSTANT: GL_RGB16F HEX: 881B
+CONSTANT: GL_TEXTURE_RED_TYPE HEX: 8C10
+CONSTANT: GL_TEXTURE_GREEN_TYPE HEX: 8C11
+CONSTANT: GL_TEXTURE_BLUE_TYPE HEX: 8C12
+CONSTANT: GL_TEXTURE_ALPHA_TYPE HEX: 8C13
+CONSTANT: GL_TEXTURE_DEPTH_TYPE HEX: 8C16
+CONSTANT: GL_UNSIGNED_NORMALIZED HEX: 8C17
+
+CONSTANT: GL_QUERY_WAIT HEX: 8E13
+CONSTANT: GL_QUERY_NO_WAIT HEX: 8E14
+CONSTANT: GL_QUERY_BY_REGION_WAIT HEX: 8E15
+CONSTANT: GL_QUERY_BY_REGION_NO_WAIT HEX: 8E16
+
+CONSTANT: GL_HALF_FLOAT HEX: 140B
+
+CONSTANT: GL_MAP_READ_BIT HEX: 0001
+CONSTANT: GL_MAP_WRITE_BIT HEX: 0002
+CONSTANT: GL_MAP_INVALIDATE_RANGE_BIT HEX: 0004
+CONSTANT: GL_MAP_INVALIDATE_BUFFER_BIT HEX: 0008
+CONSTANT: GL_MAP_FLUSH_EXPLICIT_BIT HEX: 0010
+CONSTANT: GL_MAP_UNSYNCHRONIZED_BIT HEX: 0020
+
+CONSTANT: GL_R8 HEX: 8229
+CONSTANT: GL_R16 HEX: 822A
+CONSTANT: GL_RG8 HEX: 822B
+CONSTANT: GL_RG16 HEX: 822C
+CONSTANT: GL_R16F HEX: 822D
+CONSTANT: GL_R32F HEX: 822E
+CONSTANT: GL_RG16F HEX: 822F
+CONSTANT: GL_RG32F HEX: 8230
+CONSTANT: GL_R8I HEX: 8231
+CONSTANT: GL_R8UI HEX: 8232
+CONSTANT: GL_R16I HEX: 8233
+CONSTANT: GL_R16UI HEX: 8234
+CONSTANT: GL_R32I HEX: 8235
+CONSTANT: GL_R32UI HEX: 8236
+CONSTANT: GL_RG8I HEX: 8237
+CONSTANT: GL_RG8UI HEX: 8238
+CONSTANT: GL_RG16I HEX: 8239
+CONSTANT: GL_RG16UI HEX: 823A
+CONSTANT: GL_RG32I HEX: 823B
+CONSTANT: GL_RG32UI HEX: 823C
+CONSTANT: GL_RG HEX: 8227
+CONSTANT: GL_COMPRESSED_RED HEX: 8225
+CONSTANT: GL_COMPRESSED_RG HEX: 8226
+CONSTANT: GL_RG_INTEGER HEX: 8228
+
+CONSTANT: GL_VERTEX_ARRAY_BINDING HEX: 85B5
+
+CONSTANT: GL_CLAMP_READ_COLOR HEX: 891C
+CONSTANT: GL_FIXED_ONLY HEX: 891D
+
+CONSTANT: GL_DEPTH_COMPONENT32F HEX: 8CAC
+CONSTANT: GL_DEPTH32F_STENCIL8 HEX: 8CAD
+
+CONSTANT: GL_RGB9_E5 HEX: 8C3D
+CONSTANT: GL_UNSIGNED_INT_5_9_9_9_REV HEX: 8C3E
+CONSTANT: GL_TEXTURE_SHARED_SIZE HEX: 8C3F
+
+CONSTANT: GL_R11F_G11F_B10F HEX: 8C3A
+CONSTANT: GL_UNSIGNED_INT_10F_11F_11F_REV HEX: 8C3B
+
+CONSTANT: GL_INVALID_FRAMEBUFFER_OPERATION HEX: 0506
+CONSTANT: GL_MAX_RENDERBUFFER_SIZE HEX: 84E8
+CONSTANT: GL_FRAMEBUFFER_BINDING HEX: 8CA6
+CONSTANT: GL_RENDERBUFFER_BINDING HEX: 8CA7
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE HEX: 8CD0
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME HEX: 8CD1
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL HEX: 8CD2
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE HEX: 8CD3
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_COLOR_ENCODING HEX: 8210
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_COMPONENT_TYPE HEX: 8211
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_RED_SIZE HEX: 8212
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_GREEN_SIZE HEX: 8213
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_BLUE_SIZE HEX: 8214
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_ALPHA_SIZE HEX: 8215
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_DEPTH_SIZE HEX: 8216
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_STENCIL_SIZE HEX: 8217
+CONSTANT: GL_FRAMEBUFFER_DEFAULT HEX: 8218
+CONSTANT: GL_FRAMEBUFFER_UNDEFINED HEX: 8219
+CONSTANT: GL_DEPTH_STENCIL_ATTACHMENT HEX: 821A
+CONSTANT: GL_FRAMEBUFFER_COMPLETE HEX: 8CD5
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT HEX: 8CD6
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT HEX: 8CD7
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER HEX: 8CDB
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER HEX: 8CDC
+CONSTANT: GL_FRAMEBUFFER_UNSUPPORTED HEX: 8CDD
+CONSTANT: GL_MAX_COLOR_ATTACHMENTS HEX: 8CDF
+CONSTANT: GL_COLOR_ATTACHMENT0 HEX: 8CE0
+CONSTANT: GL_COLOR_ATTACHMENT1 HEX: 8CE1
+CONSTANT: GL_COLOR_ATTACHMENT2 HEX: 8CE2
+CONSTANT: GL_COLOR_ATTACHMENT3 HEX: 8CE3
+CONSTANT: GL_COLOR_ATTACHMENT4 HEX: 8CE4
+CONSTANT: GL_COLOR_ATTACHMENT5 HEX: 8CE5
+CONSTANT: GL_COLOR_ATTACHMENT6 HEX: 8CE6
+CONSTANT: GL_COLOR_ATTACHMENT7 HEX: 8CE7
+CONSTANT: GL_COLOR_ATTACHMENT8 HEX: 8CE8
+CONSTANT: GL_COLOR_ATTACHMENT9 HEX: 8CE9
+CONSTANT: GL_COLOR_ATTACHMENT10 HEX: 8CEA
+CONSTANT: GL_COLOR_ATTACHMENT11 HEX: 8CEB
+CONSTANT: GL_COLOR_ATTACHMENT12 HEX: 8CEC
+CONSTANT: GL_COLOR_ATTACHMENT13 HEX: 8CED
+CONSTANT: GL_COLOR_ATTACHMENT14 HEX: 8CEE
+CONSTANT: GL_COLOR_ATTACHMENT15 HEX: 8CEF
+CONSTANT: GL_DEPTH_ATTACHMENT HEX: 8D00
+CONSTANT: GL_STENCIL_ATTACHMENT HEX: 8D20
+CONSTANT: GL_FRAMEBUFFER HEX: 8D40
+CONSTANT: GL_RENDERBUFFER HEX: 8D41
+CONSTANT: GL_RENDERBUFFER_WIDTH HEX: 8D42
+CONSTANT: GL_RENDERBUFFER_HEIGHT HEX: 8D43
+CONSTANT: GL_RENDERBUFFER_INTERNAL_FORMAT HEX: 8D44
+CONSTANT: GL_STENCIL_INDEX1 HEX: 8D46
+CONSTANT: GL_STENCIL_INDEX4 HEX: 8D47
+CONSTANT: GL_STENCIL_INDEX8 HEX: 8D48
+CONSTANT: GL_STENCIL_INDEX16 HEX: 8D49
+CONSTANT: GL_RENDERBUFFER_RED_SIZE HEX: 8D50
+CONSTANT: GL_RENDERBUFFER_GREEN_SIZE HEX: 8D51
+CONSTANT: GL_RENDERBUFFER_BLUE_SIZE HEX: 8D52
+CONSTANT: GL_RENDERBUFFER_ALPHA_SIZE HEX: 8D53
+CONSTANT: GL_RENDERBUFFER_DEPTH_SIZE HEX: 8D54
+CONSTANT: GL_RENDERBUFFER_STENCIL_SIZE HEX: 8D55
+
+CONSTANT: GL_READ_FRAMEBUFFER HEX: 8CA8
+CONSTANT: GL_DRAW_FRAMEBUFFER HEX: 8CA9
+
+ALIAS: GL_DRAW_FRAMEBUFFER_BINDING GL_FRAMEBUFFER_BINDING
+CONSTANT: GL_READ_FRAMEBUFFER_BINDING HEX: 8CAA
+
+CONSTANT: GL_RENDERBUFFER_SAMPLES HEX: 8CAB
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE HEX: 8D56
+CONSTANT: GL_MAX_SAMPLES HEX: 8D57
+
+CONSTANT: GL_DEPTH_STENCIL HEX: 84F9
+CONSTANT: GL_UNSIGNED_INT_24_8 HEX: 84FA
+CONSTANT: GL_DEPTH24_STENCIL8 HEX: 88F0
+CONSTANT: GL_TEXTURE_STENCIL_SIZE HEX: 88F1
+
+CONSTANT: GL_RGBA32UI HEX: 8D70
+CONSTANT: GL_RGB32UI HEX: 8D71
+
+CONSTANT: GL_RGBA16UI HEX: 8D76
+CONSTANT: GL_RGB16UI HEX: 8D77
+
+CONSTANT: GL_RGBA8UI HEX: 8D7C
+CONSTANT: GL_RGB8UI HEX: 8D7D
+
+CONSTANT: GL_RGBA32I HEX: 8D82
+CONSTANT: GL_RGB32I HEX: 8D83
+
+CONSTANT: GL_RGBA16I HEX: 8D88
+CONSTANT: GL_RGB16I HEX: 8D89
+
+CONSTANT: GL_RGBA8I HEX: 8D8E
+CONSTANT: GL_RGB8I HEX: 8D8F
+
+CONSTANT: GL_RED_INTEGER HEX: 8D94
+CONSTANT: GL_GREEN_INTEGER HEX: 8D95
+CONSTANT: GL_BLUE_INTEGER HEX: 8D96
+CONSTANT: GL_RGB_INTEGER HEX: 8D98
+CONSTANT: GL_RGBA_INTEGER HEX: 8D99
+CONSTANT: GL_BGR_INTEGER HEX: 8D9A
+CONSTANT: GL_BGRA_INTEGER HEX: 8D9B
+
+CONSTANT: GL_FLOAT_32_UNSIGNED_INT_24_8_REV HEX: 8DAD
+
+CONSTANT: GL_TEXTURE_1D_ARRAY HEX: 8C18
+CONSTANT: GL_TEXTURE_2D_ARRAY HEX: 8C1A
+
+CONSTANT: GL_PROXY_TEXTURE_2D_ARRAY HEX: 8C1B
+
+CONSTANT: GL_PROXY_TEXTURE_1D_ARRAY HEX: 8C19
+
+CONSTANT: GL_TEXTURE_BINDING_1D_ARRAY HEX: 8C1C
+CONSTANT: GL_TEXTURE_BINDING_2D_ARRAY HEX: 8C1D
+CONSTANT: GL_MAX_ARRAY_TEXTURE_LAYERS HEX: 88FF
+
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LAYER HEX: 8CD4
+
+CONSTANT: GL_SAMPLER_1D_ARRAY HEX: 8DC0
+CONSTANT: GL_SAMPLER_2D_ARRAY HEX: 8DC1
+CONSTANT: GL_SAMPLER_1D_ARRAY_SHADOW HEX: 8DC3
+CONSTANT: GL_SAMPLER_2D_ARRAY_SHADOW HEX: 8DC4
+
+CONSTANT: GL_COMPRESSED_RED_RGTC1 HEX: 8DBB
+CONSTANT: GL_COMPRESSED_SIGNED_RED_RGTC1 HEX: 8DBC
+CONSTANT: GL_COMPRESSED_RG_RGTC2 HEX: 8DBD
+CONSTANT: GL_COMPRESSED_SIGNED_RG_RGTC2 HEX: 8DBE
+
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER HEX: 8C8E
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_START HEX: 8C84
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_SIZE HEX: 8C85
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_BINDING HEX: 8C8F
+CONSTANT: GL_INTERLEAVED_ATTRIBS HEX: 8C8C
+CONSTANT: GL_SEPARATE_ATTRIBS HEX: 8C8D
+CONSTANT: GL_PRIMITIVES_GENERATED HEX: 8C87
+CONSTANT: GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN HEX: 8C88
+CONSTANT: GL_RASTERIZER_DISCARD HEX: 8C89
+CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS HEX: 8C8A
+CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS HEX: 8C8B
+CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS HEX: 8C80
+CONSTANT: GL_TRANSFORM_FEEDBACK_VARYINGS HEX: 8C83
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_MODE HEX: 8C7F
+CONSTANT: GL_TRANSFORM_FEEDBACK_VARYING_MAX_LENGTH HEX: 8C76
+
+CONSTANT: GL_FRAMEBUFFER_SRGB HEX: 8DB9
+
+CONSTANT: GL_MAJOR_VERSION HEX: 821B
+CONSTANT: GL_MINOR_VERSION HEX: 821C
+CONSTANT: GL_NUM_EXTENSIONS HEX: 821D
+CONSTANT: GL_CONTEXT_FLAGS HEX: 821E
+CONSTANT: GL_INDEX HEX: 8222
+CONSTANT: GL_DEPTH_BUFFER HEX: 8223
+CONSTANT: GL_STENCIL_BUFFER HEX: 8224
+CONSTANT: GL_CONTEXT_FLAG_FORWARD_COMPATIBLE_BIT HEX: 0001
+
+ALIAS: GL_COMPARE_REF_TO_TEXTURE GL_COMPARE_R_TO_TEXTURE
+ALIAS: GL_MAX_VARYING_COMPONENTS GL_MAX_VARYING_FLOATS
+ALIAS: GL_MAX_CLIP_DISTANCES GL_MAX_CLIP_PLANES
+ALIAS: GL_CLIP_DISTANCE0 GL_CLIP_PLANE0
+ALIAS: GL_CLIP_DISTANCE1 GL_CLIP_PLANE1
+ALIAS: GL_CLIP_DISTANCE2 GL_CLIP_PLANE2
+ALIAS: GL_CLIP_DISTANCE3 GL_CLIP_PLANE3
+ALIAS: GL_CLIP_DISTANCE4 GL_CLIP_PLANE4
+ALIAS: GL_CLIP_DISTANCE5 GL_CLIP_PLANE5
+
+GL-FUNCTION: void glVertexAttribIPointer { glVertexAttribIPointerEXT } ( GLuint index, GLint size, GLenum type, GLsizei stride, void* pointer ) ;
+
+GL-FUNCTION: void glGetVertexAttribIiv { glGetVertexAttribIivEXT } ( GLuint index, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetVertexAttribIuiv { glGetVertexAttribIuivEXT } ( GLuint index, GLenum pname, GLuint* params ) ;
+
+GL-FUNCTION: void glUniform1ui { glUniform1uiEXT } ( GLint location, GLuint v0 ) ;
+GL-FUNCTION: void glUniform2ui { glUniform2uiEXT } ( GLint location, GLuint v0, GLuint v1 ) ;
+GL-FUNCTION: void glUniform3ui { glUniform3uiEXT } ( GLint location, GLuint v0, GLuint v1, GLuint v2 ) ;
+GL-FUNCTION: void glUniform4ui { glUniform4uiEXT } ( GLint location, GLuint v0, GLuint v1, GLuint v2, GLuint v3 ) ;
+
+GL-FUNCTION: void glUniform1uiv { glUniform1uivEXT } ( GLint location, GLsizei count, GLuint* value ) ;
+GL-FUNCTION: void glUniform2uiv { glUniform2uivEXT } ( GLint location, GLsizei count, GLuint* value ) ;
+GL-FUNCTION: void glUniform3uiv { glUniform3uivEXT } ( GLint location, GLsizei count, GLuint* value ) ;
+GL-FUNCTION: void glUniform4uiv { glUniform4uivEXT } ( GLint location, GLsizei count, GLuint* value ) ;
+
+GL-FUNCTION: void glGetUniformuiv { glGetUniformuivEXT } ( GLuint program, GLint location, GLuint* params ) ;
+
+GL-FUNCTION: void glBindFragDataLocation { glBindFragDataLocationEXT } ( GLuint program, GLuint colorNumber, GLchar* name ) ;
+GL-FUNCTION: GLint glGetFragDataLocation { glGetFragDataLocationEXT } ( GLuint program, GLchar* name ) ;
+
+GL-FUNCTION: void glBeginConditionalRender { glBeginConditionalRenderNV } ( GLuint id, GLenum mode ) ;
+GL-FUNCTION: void glEndConditionalRender { glEndConditionalRenderNV } ( ) ;
+
+GL-FUNCTION: void glBindVertexArray { glBindVertexArrayAPPLE } ( GLuint array ) ;
+GL-FUNCTION: void glDeleteVertexArrays { glDeleteVertexArraysAPPLE } ( GLsizei n, GLuint* arrays ) ;
+GL-FUNCTION: void glGenVertexArrays { glGenVertexArraysAPPLE } ( GLsizei n, GLuint* arrays ) ;
+GL-FUNCTION: GLboolean glIsVertexArray { glIsVertexArrayAPPLE } ( GLuint array ) ;
+
+GL-FUNCTION: void glClampColor { glClampColorARB } ( GLenum target, GLenum clamp ) ;
+
+GL-FUNCTION: void glBindFramebuffer { glBindFramebufferEXT } ( GLenum target, GLuint framebuffer ) ;
+GL-FUNCTION: void glBindRenderbuffer { glBindRenderbufferEXT } ( GLenum target, GLuint renderbuffer ) ;
+GL-FUNCTION: GLenum glCheckFramebufferStatus { glCheckFramebufferStatusEXT } ( GLenum target ) ;
+GL-FUNCTION: void glDeleteFramebuffers { glDeleteFramebuffersEXT } ( GLsizei n, GLuint* framebuffers ) ;
+GL-FUNCTION: void glDeleteRenderbuffers { glDeleteRenderbuffersEXT } ( GLsizei n, GLuint* renderbuffers ) ;
+GL-FUNCTION: void glFramebufferRenderbuffer { glFramebufferRenderbufferEXT } ( GLenum target, GLenum attachment, GLenum renderbuffertarget, GLuint renderbuffer ) ;
+GL-FUNCTION: void glFramebufferTexture1D { glFramebufferTexture1DEXT } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ;
+GL-FUNCTION: void glFramebufferTexture2D { glFramebufferTexture2DEXT } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level ) ;
+GL-FUNCTION: void glFramebufferTexture3D { glFramebufferTexture3DEXT } ( GLenum target, GLenum attachment, GLenum textarget, GLuint texture, GLint level, GLint zoffset ) ;
+GL-FUNCTION: void glFramebufferTextureLayer { glFramebufferTextureLayerEXT }
+ ( GLenum target, GLenum attachment,
+ GLuint texture, GLint level, GLint layer ) ;
+GL-FUNCTION: void glGenFramebuffers { glGenFramebuffersEXT } ( GLsizei n, GLuint* framebuffers ) ;
+GL-FUNCTION: void glGenRenderbuffers { glGenRenderbuffersEXT } ( GLsizei n, GLuint* renderbuffers ) ;
+GL-FUNCTION: void glGenerateMipmap { glGenerateMipmapEXT } ( GLenum target ) ;
+GL-FUNCTION: void glGetFramebufferAttachmentParameteriv { glGetFramebufferAttachmentParameterivEXT } ( GLenum target, GLenum attachment, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetRenderbufferParameteriv { glGetRenderbufferParameterivEXT } ( GLenum target, GLenum pname, GLint* params ) ;
+GL-FUNCTION: GLboolean glIsFramebuffer { glIsFramebufferEXT } ( GLuint framebuffer ) ;
+GL-FUNCTION: GLboolean glIsRenderbuffer { glIsRenderbufferEXT } ( GLuint renderbuffer ) ;
+GL-FUNCTION: void glRenderbufferStorage { glRenderbufferStorageEXT } ( GLenum target, GLenum internalformat, GLsizei width, GLsizei height ) ;
+
+GL-FUNCTION: void glBlitFramebuffer { glBlitFramebufferEXT }
+ ( GLint srcX0, GLint srcY0, GLint srcX1, GLint srcY1,
GLint dstX0, GLint dstY0, GLint dstX1, GLint dstY1,
GLbitfield mask, GLenum filter ) ;
-CONSTANT: GL_READ_FRAMEBUFFER_EXT HEX: 8CA8
-CONSTANT: GL_DRAW_FRAMEBUFFER_EXT HEX: 8CA9
+GL-FUNCTION: void glRenderbufferStorageMultisample { glRenderbufferStorageMultisampleEXT } (
+ GLenum target, GLsizei samples,
+ GLenum internalformat,
+ GLsizei width, GLsizei height ) ;
-ALIAS: GL_DRAW_FRAMEBUFFER_BINDING_EXT GL_FRAMEBUFFER_BINDING_EXT
-CONSTANT: GL_READ_FRAMEBUFFER_BINDING_EXT HEX: 8CAA
+GL-FUNCTION: void glTexParameterIiv { glTexParameterIivEXT } ( GLenum target, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glTexParameterIuiv { glTexParameterIuivEXT } ( GLenum target, GLenum pname, GLuint* params ) ;
+GL-FUNCTION: void glGetTexParameterIiv { glGetTexParameterIivEXT } ( GLenum target, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetTexParameterIuiv { glGetTexParameterIuivEXT } ( GLenum target, GLenum pname, GLuint* params ) ;
+GL-FUNCTION: void glColorMaski { glColorMaskIndexedEXT }
+ ( GLuint buf, GLboolean r, GLboolean g, GLboolean b, GLboolean a ) ;
-! GL_EXT_framebuffer_multisample
+GL-FUNCTION: void glGetBooleani_v { glGetBooleanIndexedvEXT } ( GLenum value, GLuint index, GLboolean* data ) ;
+GL-FUNCTION: void glGetIntegeri_v { glGetIntegerIndexedvEXT } ( GLenum value, GLuint index, GLint* data ) ;
-GL-FUNCTION: void glRenderbufferStorageMultisampleEXT { } (
- GLenum target, GLsizei samples,
- GLenum internalformat,
- GLsizei width, GLsizei height ) ;
+GL-FUNCTION: void glEnablei { glEnableIndexedEXT } ( GLenum target, GLuint index ) ;
-CONSTANT: GL_RENDERBUFFER_SAMPLES_EXT HEX: 8CAB
-CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE_EXT HEX: 8D56
-CONSTANT: GL_MAX_SAMPLES_EXT HEX: 8D57
+GL-FUNCTION: void glDisablei { glDisableIndexedEXT } ( GLenum target, GLuint index ) ;
+GL-FUNCTION: GLboolean glIsEnabledi { glIsEnabledIndexedEXT } ( GLenum target, GLuint index ) ;
-! GL_ARB_texture_float
+GL-FUNCTION: void glBindBufferRange { glBindBufferRangeEXT } ( GLenum target, GLuint index, GLuint buffer,
+ GLintptr offset, GLsizeiptr size ) ;
+GL-FUNCTION: void glBindBufferBase { glBindBufferBaseEXT } ( GLenum target, GLuint index, GLuint buffer ) ;
+GL-FUNCTION: void glBeginTransformFeedback { glBeginTransformFeedbackEXT } ( GLenum primitiveMode ) ;
+GL-FUNCTION: void glEndTransformFeedback { glEndTransformFeedbackEXT } ( ) ;
-CONSTANT: GL_RGBA32F_ARB HEX: 8814
-CONSTANT: GL_RGB32F_ARB HEX: 8815
-CONSTANT: GL_ALPHA32F_ARB HEX: 8816
-CONSTANT: GL_INTENSITY32F_ARB HEX: 8817
-CONSTANT: GL_LUMINANCE32F_ARB HEX: 8818
-CONSTANT: GL_LUMINANCE_ALPHA32F_ARB HEX: 8819
-CONSTANT: GL_RGBA16F_ARB HEX: 881A
-CONSTANT: GL_RGB16F_ARB HEX: 881B
-CONSTANT: GL_ALPHA16F_ARB HEX: 881C
-CONSTANT: GL_INTENSITY16F_ARB HEX: 881D
-CONSTANT: GL_LUMINANCE16F_ARB HEX: 881E
-CONSTANT: GL_LUMINANCE_ALPHA16F_ARB HEX: 881F
-CONSTANT: GL_TEXTURE_RED_TYPE_ARB HEX: 8C10
-CONSTANT: GL_TEXTURE_GREEN_TYPE_ARB HEX: 8C11
-CONSTANT: GL_TEXTURE_BLUE_TYPE_ARB HEX: 8C12
-CONSTANT: GL_TEXTURE_ALPHA_TYPE_ARB HEX: 8C13
-CONSTANT: GL_TEXTURE_LUMINANCE_TYPE_ARB HEX: 8C14
-CONSTANT: GL_TEXTURE_INTENSITY_TYPE_ARB HEX: 8C15
-CONSTANT: GL_TEXTURE_DEPTH_TYPE_ARB HEX: 8C16
-CONSTANT: GL_UNSIGNED_NORMALIZED_ARB HEX: 8C17
-
-
-! GL_EXT_gpu_shader4
-
-
-GL-FUNCTION: void glVertexAttribI1iEXT { } ( GLuint index, GLint x ) ;
-GL-FUNCTION: void glVertexAttribI2iEXT { } ( GLuint index, GLint x, GLint y ) ;
-GL-FUNCTION: void glVertexAttribI3iEXT { } ( GLuint index, GLint x, GLint y, GLint z ) ;
-GL-FUNCTION: void glVertexAttribI4iEXT { } ( GLuint index, GLint x, GLint y, GLint z, GLint w ) ;
-
-GL-FUNCTION: void glVertexAttribI1uiEXT { } ( GLuint index, GLuint x ) ;
-GL-FUNCTION: void glVertexAttribI2uiEXT { } ( GLuint index, GLuint x, GLuint y ) ;
-GL-FUNCTION: void glVertexAttribI3uiEXT { } ( GLuint index, GLuint x, GLuint y, GLuint z ) ;
-GL-FUNCTION: void glVertexAttribI4uiEXT { } ( GLuint index, GLuint x, GLuint y, GLuint z, GLuint w ) ;
-
-GL-FUNCTION: void glVertexAttribI1ivEXT { } ( GLuint index, GLint* v ) ;
-GL-FUNCTION: void glVertexAttribI2ivEXT { } ( GLuint index, GLint* v ) ;
-GL-FUNCTION: void glVertexAttribI3ivEXT { } ( GLuint index, GLint* v ) ;
-GL-FUNCTION: void glVertexAttribI4ivEXT { } ( GLuint index, GLint* v ) ;
-
-GL-FUNCTION: void glVertexAttribI1uivEXT { } ( GLuint index, GLuint* v ) ;
-GL-FUNCTION: void glVertexAttribI2uivEXT { } ( GLuint index, GLuint* v ) ;
-GL-FUNCTION: void glVertexAttribI3uivEXT { } ( GLuint index, GLuint* v ) ;
-GL-FUNCTION: void glVertexAttribI4uivEXT { } ( GLuint index, GLuint* v ) ;
-
-GL-FUNCTION: void glVertexAttribI4bvEXT { } ( GLuint index, GLbyte* v ) ;
-GL-FUNCTION: void glVertexAttribI4svEXT { } ( GLuint index, GLshort* v ) ;
-GL-FUNCTION: void glVertexAttribI4ubvEXT { } ( GLuint index, GLubyte* v ) ;
-GL-FUNCTION: void glVertexAttribI4usvEXT { } ( GLuint index, GLushort* v ) ;
-
-GL-FUNCTION: void glVertexAttribIPointerEXT { } ( GLuint index, GLint size, GLenum type, GLsizei stride, void* pointer ) ;
-
-GL-FUNCTION: void glGetVertexAttribIivEXT { } ( GLuint index, GLenum pname, GLint* params ) ;
-GL-FUNCTION: void glGetVertexAttribIuivEXT { } ( GLuint index, GLenum pname, GLuint* params ) ;
-
-GL-FUNCTION: void glUniform1uiEXT { } ( GLint location, GLuint v0 ) ;
-GL-FUNCTION: void glUniform2uiEXT { } ( GLint location, GLuint v0, GLuint v1 ) ;
-GL-FUNCTION: void glUniform3uiEXT { } ( GLint location, GLuint v0, GLuint v1, GLuint v2 ) ;
-GL-FUNCTION: void glUniform4uiEXT { } ( GLint location, GLuint v0, GLuint v1, GLuint v2, GLuint v3 ) ;
-
-GL-FUNCTION: void glUniform1uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ;
-GL-FUNCTION: void glUniform2uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ;
-GL-FUNCTION: void glUniform3uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ;
-GL-FUNCTION: void glUniform4uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ;
-
-GL-FUNCTION: void glGetUniformuivEXT { } ( GLuint program, GLint location, GLuint* params ) ;
-
-GL-FUNCTION: void glBindFragDataLocationEXT { } ( GLuint program, GLuint colorNumber, GLchar* name ) ;
-GL-FUNCTION: GLint glGetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ;
-
-CONSTANT: GL_VERTEX_ATTRIB_ARRAY_INTEGER_EXT HEX: 88FD
-CONSTANT: GL_SAMPLER_1D_ARRAY_EXT HEX: 8DC0
-CONSTANT: GL_SAMPLER_2D_ARRAY_EXT HEX: 8DC1
-CONSTANT: GL_SAMPLER_BUFFER_EXT HEX: 8DC2
-CONSTANT: GL_SAMPLER_1D_ARRAY_SHADOW_EXT HEX: 8DC3
-CONSTANT: GL_SAMPLER_2D_ARRAY_SHADOW_EXT HEX: 8DC4
-CONSTANT: GL_SAMPLER_CUBE_SHADOW_EXT HEX: 8DC5
-CONSTANT: GL_UNSIGNED_INT_VEC2_EXT HEX: 8DC6
-CONSTANT: GL_UNSIGNED_INT_VEC3_EXT HEX: 8DC7
-CONSTANT: GL_UNSIGNED_INT_VEC4_EXT HEX: 8DC8
-CONSTANT: GL_INT_SAMPLER_1D_EXT HEX: 8DC9
-CONSTANT: GL_INT_SAMPLER_2D_EXT HEX: 8DCA
-CONSTANT: GL_INT_SAMPLER_3D_EXT HEX: 8DCB
-CONSTANT: GL_INT_SAMPLER_CUBE_EXT HEX: 8DCC
-CONSTANT: GL_INT_SAMPLER_2D_RECT_EXT HEX: 8DCD
-CONSTANT: GL_INT_SAMPLER_1D_ARRAY_EXT HEX: 8DCE
-CONSTANT: GL_INT_SAMPLER_2D_ARRAY_EXT HEX: 8DCF
-CONSTANT: GL_INT_SAMPLER_BUFFER_EXT HEX: 8DD0
-CONSTANT: GL_UNSIGNED_INT_SAMPLER_1D_EXT HEX: 8DD1
-CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_EXT HEX: 8DD2
-CONSTANT: GL_UNSIGNED_INT_SAMPLER_3D_EXT HEX: 8DD3
-CONSTANT: GL_UNSIGNED_INT_SAMPLER_CUBE_EXT HEX: 8DD4
-CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_RECT_EXT HEX: 8DD5
-CONSTANT: GL_UNSIGNED_INT_SAMPLER_1D_ARRAY_EXT HEX: 8DD6
-CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_ARRAY_EXT HEX: 8DD7
-CONSTANT: GL_UNSIGNED_INT_SAMPLER_BUFFER_EXT HEX: 8DD8
-CONSTANT: GL_MIN_PROGRAM_TEXEL_OFFSET_EXT HEX: 8904
-CONSTANT: GL_MAX_PROGRAM_TEXEL_OFFSET_EXT HEX: 8905
+GL-FUNCTION: void glTransformFeedbackVaryings { glTransformFeedbackVaryingsEXT } ( GLuint program, GLsizei count,
+ GLchar** varyings, GLenum bufferMode ) ;
+GL-FUNCTION: void glGetTransformFeedbackVarying { glGetTransformFeedbackVaryingEXT } ( GLuint program, GLuint index,
+ GLsizei bufSize, GLsizei* length,
+ GLsizei* size, GLenum* type, GLchar* name ) ;
+
+GL-FUNCTION: void glClearBufferiv { } ( GLenum buffer, GLint drawbuffer, GLint* value ) ;
+GL-FUNCTION: void glClearBufferuiv { } ( GLenum buffer, GLint drawbuffer, GLuint* value ) ;
+GL-FUNCTION: void glClearBufferfv { } ( GLenum buffer, GLint drawbuffer, GLfloat* value ) ;
+GL-FUNCTION: void glClearBufferfi { } ( GLenum buffer, GLint drawbuffer, GLfloat depth, GLint stencil ) ;
+
+GL-FUNCTION: GLubyte* glGetStringi { } ( GLenum value, GLuint index ) ;
+
+GL-FUNCTION: GLvoid* glMapBufferRange { } ( GLenum target, GLintptr offset, GLsizeiptr length, GLbitfield access ) ;
+GL-FUNCTION: void glFlushMappedBufferRange { glFlushMappedBufferRangeAPPLE } ( GLenum target, GLintptr offset, GLsizeiptr size ) ;
+
+
+! OpenGL 3.1
+
+CONSTANT: GL_RED_SNORM HEX: 8F90
+CONSTANT: GL_RG_SNORM HEX: 8F91
+CONSTANT: GL_RGB_SNORM HEX: 8F92
+CONSTANT: GL_RGBA_SNORM HEX: 8F93
+CONSTANT: GL_R8_SNORM HEX: 8F94
+CONSTANT: GL_RG8_SNORM HEX: 8F95
+CONSTANT: GL_RGB8_SNORM HEX: 8F96
+CONSTANT: GL_RGBA8_SNORM HEX: 8F97
+CONSTANT: GL_R16_SNORM HEX: 8F98
+CONSTANT: GL_RG16_SNORM HEX: 8F99
+CONSTANT: GL_RGB16_SNORM HEX: 8F9A
+CONSTANT: GL_RGBA16_SNORM HEX: 8F9B
+CONSTANT: GL_SIGNED_NORMALIZED HEX: 8F9C
+
+CONSTANT: GL_PRIMITIVE_RESTART HEX: 8F9D
+CONSTANT: GL_PRIMITIVE_RESTART_INDEX HEX: 8F9E
+
+CONSTANT: GL_COPY_READ_BUFFER HEX: 8F36
+CONSTANT: GL_COPY_WRITE_BUFFER HEX: 8F37
+
+CONSTANT: GL_UNIFORM_BUFFER HEX: 8A11
+CONSTANT: GL_UNIFORM_BUFFER_BINDING HEX: 8A28
+CONSTANT: GL_UNIFORM_BUFFER_START HEX: 8A29
+CONSTANT: GL_UNIFORM_BUFFER_SIZE HEX: 8A2A
+CONSTANT: GL_MAX_VERTEX_UNIFORM_BLOCKS HEX: 8A2B
+CONSTANT: GL_MAX_GEOMETRY_UNIFORM_BLOCKS HEX: 8A2C
+CONSTANT: GL_MAX_FRAGMENT_UNIFORM_BLOCKS HEX: 8A2D
+CONSTANT: GL_MAX_COMBINED_UNIFORM_BLOCKS HEX: 8A2E
+CONSTANT: GL_MAX_UNIFORM_BUFFER_BINDINGS HEX: 8A2F
+CONSTANT: GL_MAX_UNIFORM_BLOCK_SIZE HEX: 8A30
+CONSTANT: GL_MAX_COMBINED_VERTEX_UNIFORM_COMPONENTS HEX: 8A31
+CONSTANT: GL_MAX_COMBINED_GEOMETRY_UNIFORM_COMPONENTS HEX: 8A32
+CONSTANT: GL_MAX_COMBINED_FRAGMENT_UNIFORM_COMPONENTS HEX: 8A33
+CONSTANT: GL_UNIFORM_BUFFER_OFFSET_ALIGNMENT HEX: 8A34
+CONSTANT: GL_ACTIVE_UNIFORM_BLOCK_MAX_NAME_LENGTH HEX: 8A35
+CONSTANT: GL_ACTIVE_UNIFORM_BLOCKS HEX: 8A36
+CONSTANT: GL_UNIFORM_TYPE HEX: 8A37
+CONSTANT: GL_UNIFORM_SIZE HEX: 8A38
+CONSTANT: GL_UNIFORM_NAME_LENGTH HEX: 8A39
+CONSTANT: GL_UNIFORM_BLOCK_INDEX HEX: 8A3A
+CONSTANT: GL_UNIFORM_OFFSET HEX: 8A3B
+CONSTANT: GL_UNIFORM_ARRAY_STRIDE HEX: 8A3C
+CONSTANT: GL_UNIFORM_MATRIX_STRIDE HEX: 8A3D
+CONSTANT: GL_UNIFORM_IS_ROW_MAJOR HEX: 8A3E
+CONSTANT: GL_UNIFORM_BLOCK_BINDING HEX: 8A3F
+CONSTANT: GL_UNIFORM_BLOCK_DATA_SIZE HEX: 8A40
+CONSTANT: GL_UNIFORM_BLOCK_NAME_LENGTH HEX: 8A41
+CONSTANT: GL_UNIFORM_BLOCK_ACTIVE_UNIFORMS HEX: 8A42
+CONSTANT: GL_UNIFORM_BLOCK_ACTIVE_UNIFORM_INDICES HEX: 8A43
+CONSTANT: GL_UNIFORM_BLOCK_REFERENCED_BY_VERTEX_SHADER HEX: 8A44
+CONSTANT: GL_UNIFORM_BLOCK_REFERENCED_BY_GEOMETRY_SHADER HEX: 8A45
+CONSTANT: GL_UNIFORM_BLOCK_REFERENCED_BY_FRAGMENT_SHADER HEX: 8A46
+CONSTANT: GL_INVALID_INDEX HEX: FFFFFFFF
+
+CONSTANT: GL_TEXTURE_RECTANGLE HEX: 84F5
+CONSTANT: GL_TEXTURE_BINDING_RECTANGLE HEX: 84F6
+CONSTANT: GL_PROXY_TEXTURE_RECTANGLE HEX: 84F7
+CONSTANT: GL_MAX_RECTANGLE_TEXTURE_SIZE HEX: 84F8
+CONSTANT: GL_SAMPLER_2D_RECT HEX: 8B63
+CONSTANT: GL_SAMPLER_2D_RECT_SHADOW HEX: 8B64
+
+CONSTANT: GL_SAMPLER_BUFFER HEX: 8DC2
+CONSTANT: GL_INT_SAMPLER_BUFFER HEX: 8DD0
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_BUFFER HEX: 8DD8
+
+CONSTANT: GL_TEXTURE_BUFFER HEX: 8C2A
+
+CONSTANT: GL_MAX_TEXTURE_BUFFER_SIZE HEX: 8C2B
+CONSTANT: GL_TEXTURE_BINDING_BUFFER HEX: 8C2C
+CONSTANT: GL_TEXTURE_BUFFER_DATA_STORE_BINDING HEX: 8C2D
+CONSTANT: GL_TEXTURE_BUFFER_FORMAT HEX: 8C2E
+
+GL-FUNCTION: void glDrawArraysInstanced { glDrawArraysInstancedARB } ( GLenum mode, GLint first, GLsizei count, GLsizei primcount ) ;
+GL-FUNCTION: void glDrawElementsInstanced { glDrawElementsInstancedARB } ( GLenum mode, GLsizei count, GLenum type, GLvoid* indices, GLsizei primcount ) ;
+GL-FUNCTION: void glTexBuffer { glTexBufferEXT } ( GLenum target, GLenum internalformat, GLuint buffer ) ;
+GL-FUNCTION: void glPrimitiveRestartIndex { } ( GLuint index ) ;
+
+GL-FUNCTION: void glGetUniformIndices { } ( GLuint program, GLsizei uniformCount, GLchar** uniformNames, GLuint* uniformIndices ) ;
+GL-FUNCTION: void glGetActiveUniformsiv { } ( GLuint program, GLsizei uniformCount, GLuint* uniformIndices, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetActiveUniformName { } ( GLuint program, GLuint uniformIndex, GLsizei bufSize, GLsizei* length, GLchar* uniformName ) ;
+GL-FUNCTION: GLuint glGetUniformBlockIndex { } ( GLuint program, GLchar* uniformBlockName ) ;
+GL-FUNCTION: void glGetActiveUniformBlockiv { } ( GLuint program, GLuint uniformBlockIndex, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetActiveUniformBlockName { } ( GLuint program, GLuint uniformBlockIndex, GLsizei bufSize, GLsizei* length, GLchar* uniformName ) ;
+GL-FUNCTION: void glUniformBlockBinding { } ( GLuint buffer, GLuint uniformBlockIndex, GLuint uniformBlockBinding ) ;
+
+GL-FUNCTION: void glCopyBufferSubData { glCopyBufferSubDataEXT } ( GLenum readtarget, GLenum writetarget, GLintptr readoffset, GLintptr writeoffset, GLsizeiptr size ) ;
! GL_EXT_geometry_shader4
GL-FUNCTION: void glProgramParameteriEXT { } ( GLuint program, GLenum pname, GLint value ) ;
GL-FUNCTION: void glFramebufferTextureEXT { } ( GLenum target, GLenum attachment,
GLuint texture, GLint level ) ;
-GL-FUNCTION: void glFramebufferTextureLayerEXT { } ( GLenum target, GLenum attachment,
- GLuint texture, GLint level, GLint layer ) ;
-GL-FUNCTION: void glFramebufferTextureFaceEXT { } ( GLenum target, GLenum attachment,
- GLuint texture, GLint level, GLenum face ) ;
CONSTANT: GL_GEOMETRY_SHADER_EXT HEX: 8DD9
CONSTANT: GL_GEOMETRY_VERTICES_OUT_EXT HEX: 8DDA
CONSTANT: GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS_EXT HEX: 8C29
CONSTANT: GL_MAX_GEOMETRY_VARYING_COMPONENTS_EXT HEX: 8DDD
CONSTANT: GL_MAX_VERTEX_VARYING_COMPONENTS_EXT HEX: 8DDE
-CONSTANT: GL_MAX_VARYING_COMPONENTS_EXT HEX: 8B4B
CONSTANT: GL_MAX_GEOMETRY_UNIFORM_COMPONENTS_EXT HEX: 8DDF
CONSTANT: GL_MAX_GEOMETRY_OUTPUT_VERTICES_EXT HEX: 8DE0
CONSTANT: GL_MAX_GEOMETRY_TOTAL_OUTPUT_COMPONENTS_EXT HEX: 8DE1
CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS_EXT HEX: 8DA8
CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_LAYER_COUNT_EXT HEX: 8DA9
CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_LAYERED_EXT HEX: 8DA7
-ALIAS: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LAYER_EXT GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_3D_ZOFFSET_EXT
CONSTANT: GL_PROGRAM_POINT_SIZE_EXT HEX: 8642
-! GL_EXT_texture_integer
+! GL_EXT_framebuffer_object
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT HEX: 8CD9
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT HEX: 8CDA
-GL-FUNCTION: void glClearColorIiEXT { } ( GLint r, GLint g, GLint b, GLint a ) ;
-GL-FUNCTION: void glClearColorIuiEXT { } ( GLuint r, GLuint g, GLuint b, GLuint a ) ;
-GL-FUNCTION: void glTexParameterIivEXT { } ( GLenum target, GLenum pname, GLint* params ) ;
-GL-FUNCTION: void glTexParameterIuivEXT { } ( GLenum target, GLenum pname, GLuint* params ) ;
-GL-FUNCTION: void glGetTexParameterIivEXT { } ( GLenum target, GLenum pname, GLint* params ) ;
-GL-FUNCTION: void glGetTexParameterIuivEXT { } ( GLenum target, GLenum pname, GLuint* params ) ;
+! GL_ARB_texture_float
+
+CONSTANT: GL_ALPHA32F_ARB HEX: 8816
+CONSTANT: GL_INTENSITY32F_ARB HEX: 8817
+CONSTANT: GL_LUMINANCE32F_ARB HEX: 8818
+CONSTANT: GL_LUMINANCE_ALPHA32F_ARB HEX: 8819
+CONSTANT: GL_ALPHA16F_ARB HEX: 881C
+CONSTANT: GL_INTENSITY16F_ARB HEX: 881D
+CONSTANT: GL_LUMINANCE16F_ARB HEX: 881E
+CONSTANT: GL_LUMINANCE_ALPHA16F_ARB HEX: 881F
+CONSTANT: GL_TEXTURE_LUMINANCE_TYPE_ARB HEX: 8C14
+CONSTANT: GL_TEXTURE_INTENSITY_TYPE_ARB HEX: 8C15
-CONSTANT: GL_RGBA_INTEGER_MODE_EXT HEX: 8D9E
+! GL_EXT_texture_integer
-CONSTANT: GL_RGBA32UI_EXT HEX: 8D70
-CONSTANT: GL_RGB32UI_EXT HEX: 8D71
CONSTANT: GL_ALPHA32UI_EXT HEX: 8D72
CONSTANT: GL_INTENSITY32UI_EXT HEX: 8D73
CONSTANT: GL_LUMINANCE32UI_EXT HEX: 8D74
CONSTANT: GL_LUMINANCE_ALPHA32UI_EXT HEX: 8D75
-CONSTANT: GL_RGBA16UI_EXT HEX: 8D76
-CONSTANT: GL_RGB16UI_EXT HEX: 8D77
CONSTANT: GL_ALPHA16UI_EXT HEX: 8D78
CONSTANT: GL_INTENSITY16UI_EXT HEX: 8D79
CONSTANT: GL_LUMINANCE16UI_EXT HEX: 8D7A
CONSTANT: GL_LUMINANCE_ALPHA16UI_EXT HEX: 8D7B
-CONSTANT: GL_RGBA8UI_EXT HEX: 8D7C
-CONSTANT: GL_RGB8UI_EXT HEX: 8D7D
CONSTANT: GL_ALPHA8UI_EXT HEX: 8D7E
CONSTANT: GL_INTENSITY8UI_EXT HEX: 8D7F
CONSTANT: GL_LUMINANCE8UI_EXT HEX: 8D80
CONSTANT: GL_LUMINANCE_ALPHA8UI_EXT HEX: 8D81
-CONSTANT: GL_RGBA32I_EXT HEX: 8D82
-CONSTANT: GL_RGB32I_EXT HEX: 8D83
CONSTANT: GL_ALPHA32I_EXT HEX: 8D84
CONSTANT: GL_INTENSITY32I_EXT HEX: 8D85
CONSTANT: GL_LUMINANCE32I_EXT HEX: 8D86
CONSTANT: GL_LUMINANCE_ALPHA32I_EXT HEX: 8D87
-CONSTANT: GL_RGBA16I_EXT HEX: 8D88
-CONSTANT: GL_RGB16I_EXT HEX: 8D89
CONSTANT: GL_ALPHA16I_EXT HEX: 8D8A
CONSTANT: GL_INTENSITY16I_EXT HEX: 8D8B
CONSTANT: GL_LUMINANCE16I_EXT HEX: 8D8C
CONSTANT: GL_LUMINANCE_ALPHA16I_EXT HEX: 8D8D
-CONSTANT: GL_RGBA8I_EXT HEX: 8D8E
-CONSTANT: GL_RGB8I_EXT HEX: 8D8F
CONSTANT: GL_ALPHA8I_EXT HEX: 8D90
CONSTANT: GL_INTENSITY8I_EXT HEX: 8D91
CONSTANT: GL_LUMINANCE8I_EXT HEX: 8D92
CONSTANT: GL_LUMINANCE_ALPHA8I_EXT HEX: 8D93
-CONSTANT: GL_RED_INTEGER_EXT HEX: 8D94
-CONSTANT: GL_GREEN_INTEGER_EXT HEX: 8D95
-CONSTANT: GL_BLUE_INTEGER_EXT HEX: 8D96
CONSTANT: GL_ALPHA_INTEGER_EXT HEX: 8D97
-CONSTANT: GL_RGB_INTEGER_EXT HEX: 8D98
-CONSTANT: GL_RGBA_INTEGER_EXT HEX: 8D99
-CONSTANT: GL_BGR_INTEGER_EXT HEX: 8D9A
-CONSTANT: GL_BGRA_INTEGER_EXT HEX: 8D9B
-CONSTANT: GL_LUMINANCE_INTEGER_EXT HEX: 8D9C
-CONSTANT: GL_LUMINANCE_ALPHA_INTEGER_EXT HEX: 8D9D
-
-
-! GL_EXT_transform_feedback
-
-
-GL-FUNCTION: void glBindBufferRangeEXT { } ( GLenum target, GLuint index, GLuint buffer,
- GLintptr offset, GLsizeiptr size ) ;
-GL-FUNCTION: void glBindBufferOffsetEXT { } ( GLenum target, GLuint index, GLuint buffer,
- GLintptr offset ) ;
-GL-FUNCTION: void glBindBufferBaseEXT { } ( GLenum target, GLuint index, GLuint buffer ) ;
-
-GL-FUNCTION: void glBeginTransformFeedbackEXT { } ( GLenum primitiveMode ) ;
-GL-FUNCTION: void glEndTransformFeedbackEXT { } ( ) ;
-
-GL-FUNCTION: void glTransformFeedbackVaryingsEXT { } ( GLuint program, GLsizei count,
- GLchar** varyings, GLenum bufferMode ) ;
-GL-FUNCTION: void glGetTransformFeedbackVaryingEXT { } ( GLuint program, GLuint index,
- GLsizei bufSize, GLsizei* length,
- GLsizei* size, GLenum* type, GLchar* name ) ;
+CONSTANT: GL_LUMINANCE_INTEGER_EXT HEX: 8D9C
+CONSTANT: GL_LUMINANCE_ALPHA_INTEGER_EXT HEX: 8D9D
-GL-FUNCTION: void glGetIntegerIndexedvEXT { } ( GLenum param, GLuint index, GLint* values ) ;
-GL-FUNCTION: void glGetBooleanIndexedvEXT { } ( GLenum param, GLuint index, GLboolean* values ) ;
-
-CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_EXT HEX: 8C8E
-CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_START_EXT HEX: 8C84
-CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_SIZE_EXT HEX: 8C85
-CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_BINDING_EXT HEX: 8C8F
-CONSTANT: GL_INTERLEAVED_ATTRIBS_EXT HEX: 8C8C
-CONSTANT: GL_SEPARATE_ATTRIBS_EXT HEX: 8C8D
-CONSTANT: GL_PRIMITIVES_GENERATED_EXT HEX: 8C87
-CONSTANT: GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN_EXT HEX: 8C88
-CONSTANT: GL_RASTERIZER_DISCARD_EXT HEX: 8C89
-CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS_EXT HEX: 8C8A
-CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS_EXT HEX: 8C8B
-CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS_EXT HEX: 8C80
-CONSTANT: GL_TRANSFORM_FEEDBACK_VARYINGS_EXT HEX: 8C83
-CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_MODE_EXT HEX: 8C7F
-CONSTANT: GL_TRANSFORM_FEEDBACK_VARYING_MAX_LENGTH_EXT HEX: 8C76
+GL-FUNCTION: void glClearColorIiEXT { } ( GLint r, GLint g, GLint b, GLint a ) ;
+GL-FUNCTION: void glClearColorIuiEXT { } ( GLuint r, GLuint g, GLuint b, GLuint a ) ;
--- /dev/null
+! (c)2009 Joe Groff bsd license
+! This vocab only exports forward-compatible OpenGL 3.x symbols.
+! For legacy OpenGL and extensions, use opengl.gl
+
+QUALIFIED-WITH: opengl.gl gl
+IN: opengl.gl3
+
+ALIAS: GL_DEPTH_BUFFER_BIT gl:GL_DEPTH_BUFFER_BIT
+ALIAS: GL_STENCIL_BUFFER_BIT gl:GL_STENCIL_BUFFER_BIT
+ALIAS: GL_COLOR_BUFFER_BIT gl:GL_COLOR_BUFFER_BIT
+ALIAS: GL_FALSE gl:GL_FALSE
+ALIAS: GL_TRUE gl:GL_TRUE
+ALIAS: GL_POINTS gl:GL_POINTS
+ALIAS: GL_LINES gl:GL_LINES
+ALIAS: GL_LINE_LOOP gl:GL_LINE_LOOP
+ALIAS: GL_LINE_STRIP gl:GL_LINE_STRIP
+ALIAS: GL_TRIANGLES gl:GL_TRIANGLES
+ALIAS: GL_TRIANGLE_STRIP gl:GL_TRIANGLE_STRIP
+ALIAS: GL_TRIANGLE_FAN gl:GL_TRIANGLE_FAN
+ALIAS: GL_NEVER gl:GL_NEVER
+ALIAS: GL_LESS gl:GL_LESS
+ALIAS: GL_EQUAL gl:GL_EQUAL
+ALIAS: GL_LEQUAL gl:GL_LEQUAL
+ALIAS: GL_GREATER gl:GL_GREATER
+ALIAS: GL_NOTEQUAL gl:GL_NOTEQUAL
+ALIAS: GL_GEQUAL gl:GL_GEQUAL
+ALIAS: GL_ALWAYS gl:GL_ALWAYS
+ALIAS: GL_ZERO gl:GL_ZERO
+ALIAS: GL_ONE gl:GL_ONE
+ALIAS: GL_SRC_COLOR gl:GL_SRC_COLOR
+ALIAS: GL_ONE_MINUS_SRC_COLOR gl:GL_ONE_MINUS_SRC_COLOR
+ALIAS: GL_SRC_ALPHA gl:GL_SRC_ALPHA
+ALIAS: GL_ONE_MINUS_SRC_ALPHA gl:GL_ONE_MINUS_SRC_ALPHA
+ALIAS: GL_DST_ALPHA gl:GL_DST_ALPHA
+ALIAS: GL_ONE_MINUS_DST_ALPHA gl:GL_ONE_MINUS_DST_ALPHA
+ALIAS: GL_DST_COLOR gl:GL_DST_COLOR
+ALIAS: GL_ONE_MINUS_DST_COLOR gl:GL_ONE_MINUS_DST_COLOR
+ALIAS: GL_SRC_ALPHA_SATURATE gl:GL_SRC_ALPHA_SATURATE
+ALIAS: GL_NONE gl:GL_NONE
+ALIAS: GL_FRONT_LEFT gl:GL_FRONT_LEFT
+ALIAS: GL_FRONT_RIGHT gl:GL_FRONT_RIGHT
+ALIAS: GL_BACK_LEFT gl:GL_BACK_LEFT
+ALIAS: GL_BACK_RIGHT gl:GL_BACK_RIGHT
+ALIAS: GL_FRONT gl:GL_FRONT
+ALIAS: GL_BACK gl:GL_BACK
+ALIAS: GL_LEFT gl:GL_LEFT
+ALIAS: GL_RIGHT gl:GL_RIGHT
+ALIAS: GL_FRONT_AND_BACK gl:GL_FRONT_AND_BACK
+ALIAS: GL_NO_ERROR gl:GL_NO_ERROR
+ALIAS: GL_INVALID_ENUM gl:GL_INVALID_ENUM
+ALIAS: GL_INVALID_VALUE gl:GL_INVALID_VALUE
+ALIAS: GL_INVALID_OPERATION gl:GL_INVALID_OPERATION
+ALIAS: GL_OUT_OF_MEMORY gl:GL_OUT_OF_MEMORY
+ALIAS: GL_CW gl:GL_CW
+ALIAS: GL_CCW gl:GL_CCW
+ALIAS: GL_POINT_SIZE gl:GL_POINT_SIZE
+ALIAS: GL_POINT_SIZE_RANGE gl:GL_POINT_SIZE_RANGE
+ALIAS: GL_POINT_SIZE_GRANULARITY gl:GL_POINT_SIZE_GRANULARITY
+ALIAS: GL_LINE_SMOOTH gl:GL_LINE_SMOOTH
+ALIAS: GL_LINE_WIDTH gl:GL_LINE_WIDTH
+ALIAS: GL_LINE_WIDTH_RANGE gl:GL_LINE_WIDTH_RANGE
+ALIAS: GL_LINE_WIDTH_GRANULARITY gl:GL_LINE_WIDTH_GRANULARITY
+ALIAS: GL_POLYGON_SMOOTH gl:GL_POLYGON_SMOOTH
+ALIAS: GL_CULL_FACE gl:GL_CULL_FACE
+ALIAS: GL_CULL_FACE_MODE gl:GL_CULL_FACE_MODE
+ALIAS: GL_FRONT_FACE gl:GL_FRONT_FACE
+ALIAS: GL_DEPTH_RANGE gl:GL_DEPTH_RANGE
+ALIAS: GL_DEPTH_TEST gl:GL_DEPTH_TEST
+ALIAS: GL_DEPTH_WRITEMASK gl:GL_DEPTH_WRITEMASK
+ALIAS: GL_DEPTH_CLEAR_VALUE gl:GL_DEPTH_CLEAR_VALUE
+ALIAS: GL_DEPTH_FUNC gl:GL_DEPTH_FUNC
+ALIAS: GL_STENCIL_TEST gl:GL_STENCIL_TEST
+ALIAS: GL_STENCIL_CLEAR_VALUE gl:GL_STENCIL_CLEAR_VALUE
+ALIAS: GL_STENCIL_FUNC gl:GL_STENCIL_FUNC
+ALIAS: GL_STENCIL_VALUE_MASK gl:GL_STENCIL_VALUE_MASK
+ALIAS: GL_STENCIL_FAIL gl:GL_STENCIL_FAIL
+ALIAS: GL_STENCIL_PASS_DEPTH_FAIL gl:GL_STENCIL_PASS_DEPTH_FAIL
+ALIAS: GL_STENCIL_PASS_DEPTH_PASS gl:GL_STENCIL_PASS_DEPTH_PASS
+ALIAS: GL_STENCIL_REF gl:GL_STENCIL_REF
+ALIAS: GL_STENCIL_WRITEMASK gl:GL_STENCIL_WRITEMASK
+ALIAS: GL_VIEWPORT gl:GL_VIEWPORT
+ALIAS: GL_DITHER gl:GL_DITHER
+ALIAS: GL_BLEND_DST gl:GL_BLEND_DST
+ALIAS: GL_BLEND_SRC gl:GL_BLEND_SRC
+ALIAS: GL_BLEND gl:GL_BLEND
+ALIAS: GL_LOGIC_OP_MODE gl:GL_LOGIC_OP_MODE
+ALIAS: GL_COLOR_LOGIC_OP gl:GL_COLOR_LOGIC_OP
+ALIAS: GL_DRAW_BUFFER gl:GL_DRAW_BUFFER
+ALIAS: GL_READ_BUFFER gl:GL_READ_BUFFER
+ALIAS: GL_SCISSOR_BOX gl:GL_SCISSOR_BOX
+ALIAS: GL_SCISSOR_TEST gl:GL_SCISSOR_TEST
+ALIAS: GL_COLOR_CLEAR_VALUE gl:GL_COLOR_CLEAR_VALUE
+ALIAS: GL_COLOR_WRITEMASK gl:GL_COLOR_WRITEMASK
+ALIAS: GL_DOUBLEBUFFER gl:GL_DOUBLEBUFFER
+ALIAS: GL_STEREO gl:GL_STEREO
+ALIAS: GL_LINE_SMOOTH_HINT gl:GL_LINE_SMOOTH_HINT
+ALIAS: GL_POLYGON_SMOOTH_HINT gl:GL_POLYGON_SMOOTH_HINT
+ALIAS: GL_UNPACK_SWAP_BYTES gl:GL_UNPACK_SWAP_BYTES
+ALIAS: GL_UNPACK_LSB_FIRST gl:GL_UNPACK_LSB_FIRST
+ALIAS: GL_UNPACK_ROW_LENGTH gl:GL_UNPACK_ROW_LENGTH
+ALIAS: GL_UNPACK_SKIP_ROWS gl:GL_UNPACK_SKIP_ROWS
+ALIAS: GL_UNPACK_SKIP_PIXELS gl:GL_UNPACK_SKIP_PIXELS
+ALIAS: GL_UNPACK_ALIGNMENT gl:GL_UNPACK_ALIGNMENT
+ALIAS: GL_PACK_SWAP_BYTES gl:GL_PACK_SWAP_BYTES
+ALIAS: GL_PACK_LSB_FIRST gl:GL_PACK_LSB_FIRST
+ALIAS: GL_PACK_ROW_LENGTH gl:GL_PACK_ROW_LENGTH
+ALIAS: GL_PACK_SKIP_ROWS gl:GL_PACK_SKIP_ROWS
+ALIAS: GL_PACK_SKIP_PIXELS gl:GL_PACK_SKIP_PIXELS
+ALIAS: GL_PACK_ALIGNMENT gl:GL_PACK_ALIGNMENT
+ALIAS: GL_MAX_TEXTURE_SIZE gl:GL_MAX_TEXTURE_SIZE
+ALIAS: GL_MAX_VIEWPORT_DIMS gl:GL_MAX_VIEWPORT_DIMS
+ALIAS: GL_SUBPIXEL_BITS gl:GL_SUBPIXEL_BITS
+ALIAS: GL_TEXTURE_1D gl:GL_TEXTURE_1D
+ALIAS: GL_TEXTURE_2D gl:GL_TEXTURE_2D
+ALIAS: GL_POLYGON_OFFSET_UNITS gl:GL_POLYGON_OFFSET_UNITS
+ALIAS: GL_POLYGON_OFFSET_POINT gl:GL_POLYGON_OFFSET_POINT
+ALIAS: GL_POLYGON_OFFSET_LINE gl:GL_POLYGON_OFFSET_LINE
+ALIAS: GL_POLYGON_OFFSET_FILL gl:GL_POLYGON_OFFSET_FILL
+ALIAS: GL_POLYGON_OFFSET_FACTOR gl:GL_POLYGON_OFFSET_FACTOR
+ALIAS: GL_TEXTURE_BINDING_1D gl:GL_TEXTURE_BINDING_1D
+ALIAS: GL_TEXTURE_BINDING_2D gl:GL_TEXTURE_BINDING_2D
+ALIAS: GL_TEXTURE_WIDTH gl:GL_TEXTURE_WIDTH
+ALIAS: GL_TEXTURE_HEIGHT gl:GL_TEXTURE_HEIGHT
+ALIAS: GL_TEXTURE_INTERNAL_FORMAT gl:GL_TEXTURE_INTERNAL_FORMAT
+ALIAS: GL_TEXTURE_BORDER_COLOR gl:GL_TEXTURE_BORDER_COLOR
+ALIAS: GL_TEXTURE_BORDER gl:GL_TEXTURE_BORDER
+ALIAS: GL_TEXTURE_RED_SIZE gl:GL_TEXTURE_RED_SIZE
+ALIAS: GL_TEXTURE_GREEN_SIZE gl:GL_TEXTURE_GREEN_SIZE
+ALIAS: GL_TEXTURE_BLUE_SIZE gl:GL_TEXTURE_BLUE_SIZE
+ALIAS: GL_TEXTURE_ALPHA_SIZE gl:GL_TEXTURE_ALPHA_SIZE
+ALIAS: GL_DONT_CARE gl:GL_DONT_CARE
+ALIAS: GL_FASTEST gl:GL_FASTEST
+ALIAS: GL_NICEST gl:GL_NICEST
+ALIAS: GL_BYTE gl:GL_BYTE
+ALIAS: GL_UNSIGNED_BYTE gl:GL_UNSIGNED_BYTE
+ALIAS: GL_SHORT gl:GL_SHORT
+ALIAS: GL_UNSIGNED_SHORT gl:GL_UNSIGNED_SHORT
+ALIAS: GL_INT gl:GL_INT
+ALIAS: GL_UNSIGNED_INT gl:GL_UNSIGNED_INT
+ALIAS: GL_FLOAT gl:GL_FLOAT
+ALIAS: GL_DOUBLE gl:GL_DOUBLE
+ALIAS: GL_CLEAR gl:GL_CLEAR
+ALIAS: GL_AND gl:GL_AND
+ALIAS: GL_AND_REVERSE gl:GL_AND_REVERSE
+ALIAS: GL_COPY gl:GL_COPY
+ALIAS: GL_AND_INVERTED gl:GL_AND_INVERTED
+ALIAS: GL_NOOP gl:GL_NOOP
+ALIAS: GL_XOR gl:GL_XOR
+ALIAS: GL_OR gl:GL_OR
+ALIAS: GL_NOR gl:GL_NOR
+ALIAS: GL_EQUIV gl:GL_EQUIV
+ALIAS: GL_INVERT gl:GL_INVERT
+ALIAS: GL_OR_REVERSE gl:GL_OR_REVERSE
+ALIAS: GL_COPY_INVERTED gl:GL_COPY_INVERTED
+ALIAS: GL_OR_INVERTED gl:GL_OR_INVERTED
+ALIAS: GL_NAND gl:GL_NAND
+ALIAS: GL_SET gl:GL_SET
+ALIAS: GL_TEXTURE gl:GL_TEXTURE
+ALIAS: GL_COLOR gl:GL_COLOR
+ALIAS: GL_DEPTH gl:GL_DEPTH
+ALIAS: GL_STENCIL gl:GL_STENCIL
+ALIAS: GL_STENCIL_INDEX gl:GL_STENCIL_INDEX
+ALIAS: GL_DEPTH_COMPONENT gl:GL_DEPTH_COMPONENT
+ALIAS: GL_RED gl:GL_RED
+ALIAS: GL_GREEN gl:GL_GREEN
+ALIAS: GL_BLUE gl:GL_BLUE
+ALIAS: GL_ALPHA gl:GL_ALPHA
+ALIAS: GL_RGB gl:GL_RGB
+ALIAS: GL_RGBA gl:GL_RGBA
+ALIAS: GL_POINT gl:GL_POINT
+ALIAS: GL_LINE gl:GL_LINE
+ALIAS: GL_FILL gl:GL_FILL
+ALIAS: GL_KEEP gl:GL_KEEP
+ALIAS: GL_REPLACE gl:GL_REPLACE
+ALIAS: GL_INCR gl:GL_INCR
+ALIAS: GL_DECR gl:GL_DECR
+ALIAS: GL_VENDOR gl:GL_VENDOR
+ALIAS: GL_RENDERER gl:GL_RENDERER
+ALIAS: GL_VERSION gl:GL_VERSION
+ALIAS: GL_EXTENSIONS gl:GL_EXTENSIONS
+ALIAS: GL_NEAREST gl:GL_NEAREST
+ALIAS: GL_LINEAR gl:GL_LINEAR
+ALIAS: GL_NEAREST_MIPMAP_NEAREST gl:GL_NEAREST_MIPMAP_NEAREST
+ALIAS: GL_LINEAR_MIPMAP_NEAREST gl:GL_LINEAR_MIPMAP_NEAREST
+ALIAS: GL_NEAREST_MIPMAP_LINEAR gl:GL_NEAREST_MIPMAP_LINEAR
+ALIAS: GL_LINEAR_MIPMAP_LINEAR gl:GL_LINEAR_MIPMAP_LINEAR
+ALIAS: GL_TEXTURE_MAG_FILTER gl:GL_TEXTURE_MAG_FILTER
+ALIAS: GL_TEXTURE_MIN_FILTER gl:GL_TEXTURE_MIN_FILTER
+ALIAS: GL_TEXTURE_WRAP_S gl:GL_TEXTURE_WRAP_S
+ALIAS: GL_TEXTURE_WRAP_T gl:GL_TEXTURE_WRAP_T
+ALIAS: GL_PROXY_TEXTURE_1D gl:GL_PROXY_TEXTURE_1D
+ALIAS: GL_PROXY_TEXTURE_2D gl:GL_PROXY_TEXTURE_2D
+ALIAS: GL_REPEAT gl:GL_REPEAT
+ALIAS: GL_R3_G3_B2 gl:GL_R3_G3_B2
+ALIAS: GL_RGB4 gl:GL_RGB4
+ALIAS: GL_RGB5 gl:GL_RGB5
+ALIAS: GL_RGB8 gl:GL_RGB8
+ALIAS: GL_RGB10 gl:GL_RGB10
+ALIAS: GL_RGB12 gl:GL_RGB12
+ALIAS: GL_RGB16 gl:GL_RGB16
+ALIAS: GL_RGBA2 gl:GL_RGBA2
+ALIAS: GL_RGBA4 gl:GL_RGBA4
+ALIAS: GL_RGB5_A1 gl:GL_RGB5_A1
+ALIAS: GL_RGBA8 gl:GL_RGBA8
+ALIAS: GL_RGB10_A2 gl:GL_RGB10_A2
+ALIAS: GL_RGBA12 gl:GL_RGBA12
+ALIAS: GL_RGBA16 gl:GL_RGBA16
+ALIAS: GL_UNSIGNED_BYTE_3_3_2 gl:GL_UNSIGNED_BYTE_3_3_2
+ALIAS: GL_UNSIGNED_SHORT_4_4_4_4 gl:GL_UNSIGNED_SHORT_4_4_4_4
+ALIAS: GL_UNSIGNED_SHORT_5_5_5_1 gl:GL_UNSIGNED_SHORT_5_5_5_1
+ALIAS: GL_UNSIGNED_INT_8_8_8_8 gl:GL_UNSIGNED_INT_8_8_8_8
+ALIAS: GL_UNSIGNED_INT_10_10_10_2 gl:GL_UNSIGNED_INT_10_10_10_2
+ALIAS: GL_TEXTURE_BINDING_3D gl:GL_TEXTURE_BINDING_3D
+ALIAS: GL_PACK_SKIP_IMAGES gl:GL_PACK_SKIP_IMAGES
+ALIAS: GL_PACK_IMAGE_HEIGHT gl:GL_PACK_IMAGE_HEIGHT
+ALIAS: GL_UNPACK_SKIP_IMAGES gl:GL_UNPACK_SKIP_IMAGES
+ALIAS: GL_UNPACK_IMAGE_HEIGHT gl:GL_UNPACK_IMAGE_HEIGHT
+ALIAS: GL_TEXTURE_3D gl:GL_TEXTURE_3D
+ALIAS: GL_PROXY_TEXTURE_3D gl:GL_PROXY_TEXTURE_3D
+ALIAS: GL_TEXTURE_DEPTH gl:GL_TEXTURE_DEPTH
+ALIAS: GL_TEXTURE_WRAP_R gl:GL_TEXTURE_WRAP_R
+ALIAS: GL_MAX_3D_TEXTURE_SIZE gl:GL_MAX_3D_TEXTURE_SIZE
+ALIAS: GL_UNSIGNED_BYTE_2_3_3_REV gl:GL_UNSIGNED_BYTE_2_3_3_REV
+ALIAS: GL_UNSIGNED_SHORT_5_6_5 gl:GL_UNSIGNED_SHORT_5_6_5
+ALIAS: GL_UNSIGNED_SHORT_5_6_5_REV gl:GL_UNSIGNED_SHORT_5_6_5_REV
+ALIAS: GL_UNSIGNED_SHORT_4_4_4_4_REV gl:GL_UNSIGNED_SHORT_4_4_4_4_REV
+ALIAS: GL_UNSIGNED_SHORT_1_5_5_5_REV gl:GL_UNSIGNED_SHORT_1_5_5_5_REV
+ALIAS: GL_UNSIGNED_INT_8_8_8_8_REV gl:GL_UNSIGNED_INT_8_8_8_8_REV
+ALIAS: GL_UNSIGNED_INT_2_10_10_10_REV gl:GL_UNSIGNED_INT_2_10_10_10_REV
+ALIAS: GL_BGR gl:GL_BGR
+ALIAS: GL_BGRA gl:GL_BGRA
+ALIAS: GL_MAX_ELEMENTS_VERTICES gl:GL_MAX_ELEMENTS_VERTICES
+ALIAS: GL_MAX_ELEMENTS_INDICES gl:GL_MAX_ELEMENTS_INDICES
+ALIAS: GL_CLAMP_TO_EDGE gl:GL_CLAMP_TO_EDGE
+ALIAS: GL_TEXTURE_MIN_LOD gl:GL_TEXTURE_MIN_LOD
+ALIAS: GL_TEXTURE_MAX_LOD gl:GL_TEXTURE_MAX_LOD
+ALIAS: GL_TEXTURE_BASE_LEVEL gl:GL_TEXTURE_BASE_LEVEL
+ALIAS: GL_TEXTURE_MAX_LEVEL gl:GL_TEXTURE_MAX_LEVEL
+ALIAS: GL_SMOOTH_POINT_SIZE_RANGE gl:GL_SMOOTH_POINT_SIZE_RANGE
+ALIAS: GL_SMOOTH_POINT_SIZE_GRANULARITY gl:GL_SMOOTH_POINT_SIZE_GRANULARITY
+ALIAS: GL_SMOOTH_LINE_WIDTH_RANGE gl:GL_SMOOTH_LINE_WIDTH_RANGE
+ALIAS: GL_SMOOTH_LINE_WIDTH_GRANULARITY gl:GL_SMOOTH_LINE_WIDTH_GRANULARITY
+ALIAS: GL_ALIASED_LINE_WIDTH_RANGE gl:GL_ALIASED_LINE_WIDTH_RANGE
+ALIAS: GL_CONSTANT_COLOR gl:GL_CONSTANT_COLOR
+ALIAS: GL_ONE_MINUS_CONSTANT_COLOR gl:GL_ONE_MINUS_CONSTANT_COLOR
+ALIAS: GL_CONSTANT_ALPHA gl:GL_CONSTANT_ALPHA
+ALIAS: GL_ONE_MINUS_CONSTANT_ALPHA gl:GL_ONE_MINUS_CONSTANT_ALPHA
+ALIAS: GL_BLEND_COLOR gl:GL_BLEND_COLOR
+ALIAS: GL_FUNC_ADD gl:GL_FUNC_ADD
+ALIAS: GL_MIN gl:GL_MIN
+ALIAS: GL_MAX gl:GL_MAX
+ALIAS: GL_BLEND_EQUATION gl:GL_BLEND_EQUATION
+ALIAS: GL_FUNC_SUBTRACT gl:GL_FUNC_SUBTRACT
+ALIAS: GL_FUNC_REVERSE_SUBTRACT gl:GL_FUNC_REVERSE_SUBTRACT
+ALIAS: GL_TEXTURE0 gl:GL_TEXTURE0
+ALIAS: GL_TEXTURE1 gl:GL_TEXTURE1
+ALIAS: GL_TEXTURE2 gl:GL_TEXTURE2
+ALIAS: GL_TEXTURE3 gl:GL_TEXTURE3
+ALIAS: GL_TEXTURE4 gl:GL_TEXTURE4
+ALIAS: GL_TEXTURE5 gl:GL_TEXTURE5
+ALIAS: GL_TEXTURE6 gl:GL_TEXTURE6
+ALIAS: GL_TEXTURE7 gl:GL_TEXTURE7
+ALIAS: GL_TEXTURE8 gl:GL_TEXTURE8
+ALIAS: GL_TEXTURE9 gl:GL_TEXTURE9
+ALIAS: GL_TEXTURE10 gl:GL_TEXTURE10
+ALIAS: GL_TEXTURE11 gl:GL_TEXTURE11
+ALIAS: GL_TEXTURE12 gl:GL_TEXTURE12
+ALIAS: GL_TEXTURE13 gl:GL_TEXTURE13
+ALIAS: GL_TEXTURE14 gl:GL_TEXTURE14
+ALIAS: GL_TEXTURE15 gl:GL_TEXTURE15
+ALIAS: GL_TEXTURE16 gl:GL_TEXTURE16
+ALIAS: GL_TEXTURE17 gl:GL_TEXTURE17
+ALIAS: GL_TEXTURE18 gl:GL_TEXTURE18
+ALIAS: GL_TEXTURE19 gl:GL_TEXTURE19
+ALIAS: GL_TEXTURE20 gl:GL_TEXTURE20
+ALIAS: GL_TEXTURE21 gl:GL_TEXTURE21
+ALIAS: GL_TEXTURE22 gl:GL_TEXTURE22
+ALIAS: GL_TEXTURE23 gl:GL_TEXTURE23
+ALIAS: GL_TEXTURE24 gl:GL_TEXTURE24
+ALIAS: GL_TEXTURE25 gl:GL_TEXTURE25
+ALIAS: GL_TEXTURE26 gl:GL_TEXTURE26
+ALIAS: GL_TEXTURE27 gl:GL_TEXTURE27
+ALIAS: GL_TEXTURE28 gl:GL_TEXTURE28
+ALIAS: GL_TEXTURE29 gl:GL_TEXTURE29
+ALIAS: GL_TEXTURE30 gl:GL_TEXTURE30
+ALIAS: GL_TEXTURE31 gl:GL_TEXTURE31
+ALIAS: GL_ACTIVE_TEXTURE gl:GL_ACTIVE_TEXTURE
+ALIAS: GL_MULTISAMPLE gl:GL_MULTISAMPLE
+ALIAS: GL_SAMPLE_ALPHA_TO_COVERAGE gl:GL_SAMPLE_ALPHA_TO_COVERAGE
+ALIAS: GL_SAMPLE_ALPHA_TO_ONE gl:GL_SAMPLE_ALPHA_TO_ONE
+ALIAS: GL_SAMPLE_COVERAGE gl:GL_SAMPLE_COVERAGE
+ALIAS: GL_SAMPLE_BUFFERS gl:GL_SAMPLE_BUFFERS
+ALIAS: GL_SAMPLES gl:GL_SAMPLES
+ALIAS: GL_SAMPLE_COVERAGE_VALUE gl:GL_SAMPLE_COVERAGE_VALUE
+ALIAS: GL_SAMPLE_COVERAGE_INVERT gl:GL_SAMPLE_COVERAGE_INVERT
+ALIAS: GL_TEXTURE_CUBE_MAP gl:GL_TEXTURE_CUBE_MAP
+ALIAS: GL_TEXTURE_BINDING_CUBE_MAP gl:GL_TEXTURE_BINDING_CUBE_MAP
+ALIAS: GL_TEXTURE_CUBE_MAP_POSITIVE_X gl:GL_TEXTURE_CUBE_MAP_POSITIVE_X
+ALIAS: GL_TEXTURE_CUBE_MAP_NEGATIVE_X gl:GL_TEXTURE_CUBE_MAP_NEGATIVE_X
+ALIAS: GL_TEXTURE_CUBE_MAP_POSITIVE_Y gl:GL_TEXTURE_CUBE_MAP_POSITIVE_Y
+ALIAS: GL_TEXTURE_CUBE_MAP_NEGATIVE_Y gl:GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
+ALIAS: GL_TEXTURE_CUBE_MAP_POSITIVE_Z gl:GL_TEXTURE_CUBE_MAP_POSITIVE_Z
+ALIAS: GL_TEXTURE_CUBE_MAP_NEGATIVE_Z gl:GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
+ALIAS: GL_PROXY_TEXTURE_CUBE_MAP gl:GL_PROXY_TEXTURE_CUBE_MAP
+ALIAS: GL_MAX_CUBE_MAP_TEXTURE_SIZE gl:GL_MAX_CUBE_MAP_TEXTURE_SIZE
+ALIAS: GL_COMPRESSED_RGB gl:GL_COMPRESSED_RGB
+ALIAS: GL_COMPRESSED_RGBA gl:GL_COMPRESSED_RGBA
+ALIAS: GL_TEXTURE_COMPRESSION_HINT gl:GL_TEXTURE_COMPRESSION_HINT
+ALIAS: GL_TEXTURE_COMPRESSED_IMAGE_SIZE gl:GL_TEXTURE_COMPRESSED_IMAGE_SIZE
+ALIAS: GL_TEXTURE_COMPRESSED gl:GL_TEXTURE_COMPRESSED
+ALIAS: GL_NUM_COMPRESSED_TEXTURE_FORMATS gl:GL_NUM_COMPRESSED_TEXTURE_FORMATS
+ALIAS: GL_COMPRESSED_TEXTURE_FORMATS gl:GL_COMPRESSED_TEXTURE_FORMATS
+ALIAS: GL_CLAMP_TO_BORDER gl:GL_CLAMP_TO_BORDER
+ALIAS: GL_BLEND_DST_RGB gl:GL_BLEND_DST_RGB
+ALIAS: GL_BLEND_SRC_RGB gl:GL_BLEND_SRC_RGB
+ALIAS: GL_BLEND_DST_ALPHA gl:GL_BLEND_DST_ALPHA
+ALIAS: GL_BLEND_SRC_ALPHA gl:GL_BLEND_SRC_ALPHA
+ALIAS: GL_POINT_FADE_THRESHOLD_SIZE gl:GL_POINT_FADE_THRESHOLD_SIZE
+ALIAS: GL_DEPTH_COMPONENT16 gl:GL_DEPTH_COMPONENT16
+ALIAS: GL_DEPTH_COMPONENT24 gl:GL_DEPTH_COMPONENT24
+ALIAS: GL_DEPTH_COMPONENT32 gl:GL_DEPTH_COMPONENT32
+ALIAS: GL_MIRRORED_REPEAT gl:GL_MIRRORED_REPEAT
+ALIAS: GL_MAX_TEXTURE_LOD_BIAS gl:GL_MAX_TEXTURE_LOD_BIAS
+ALIAS: GL_TEXTURE_LOD_BIAS gl:GL_TEXTURE_LOD_BIAS
+ALIAS: GL_INCR_WRAP gl:GL_INCR_WRAP
+ALIAS: GL_DECR_WRAP gl:GL_DECR_WRAP
+ALIAS: GL_TEXTURE_DEPTH_SIZE gl:GL_TEXTURE_DEPTH_SIZE
+ALIAS: GL_TEXTURE_COMPARE_MODE gl:GL_TEXTURE_COMPARE_MODE
+ALIAS: GL_TEXTURE_COMPARE_FUNC gl:GL_TEXTURE_COMPARE_FUNC
+ALIAS: GL_BUFFER_SIZE gl:GL_BUFFER_SIZE
+ALIAS: GL_BUFFER_USAGE gl:GL_BUFFER_USAGE
+ALIAS: GL_QUERY_COUNTER_BITS gl:GL_QUERY_COUNTER_BITS
+ALIAS: GL_CURRENT_QUERY gl:GL_CURRENT_QUERY
+ALIAS: GL_QUERY_RESULT gl:GL_QUERY_RESULT
+ALIAS: GL_QUERY_RESULT_AVAILABLE gl:GL_QUERY_RESULT_AVAILABLE
+ALIAS: GL_ARRAY_BUFFER gl:GL_ARRAY_BUFFER
+ALIAS: GL_ELEMENT_ARRAY_BUFFER gl:GL_ELEMENT_ARRAY_BUFFER
+ALIAS: GL_ARRAY_BUFFER_BINDING gl:GL_ARRAY_BUFFER_BINDING
+ALIAS: GL_ELEMENT_ARRAY_BUFFER_BINDING gl:GL_ELEMENT_ARRAY_BUFFER_BINDING
+ALIAS: GL_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING gl:GL_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING
+ALIAS: GL_READ_ONLY gl:GL_READ_ONLY
+ALIAS: GL_WRITE_ONLY gl:GL_WRITE_ONLY
+ALIAS: GL_READ_WRITE gl:GL_READ_WRITE
+ALIAS: GL_BUFFER_ACCESS gl:GL_BUFFER_ACCESS
+ALIAS: GL_BUFFER_MAPPED gl:GL_BUFFER_MAPPED
+ALIAS: GL_BUFFER_MAP_POINTER gl:GL_BUFFER_MAP_POINTER
+ALIAS: GL_STREAM_DRAW gl:GL_STREAM_DRAW
+ALIAS: GL_STREAM_READ gl:GL_STREAM_READ
+ALIAS: GL_STREAM_COPY gl:GL_STREAM_COPY
+ALIAS: GL_STATIC_DRAW gl:GL_STATIC_DRAW
+ALIAS: GL_STATIC_READ gl:GL_STATIC_READ
+ALIAS: GL_STATIC_COPY gl:GL_STATIC_COPY
+ALIAS: GL_DYNAMIC_DRAW gl:GL_DYNAMIC_DRAW
+ALIAS: GL_DYNAMIC_READ gl:GL_DYNAMIC_READ
+ALIAS: GL_DYNAMIC_COPY gl:GL_DYNAMIC_COPY
+ALIAS: GL_SAMPLES_PASSED gl:GL_SAMPLES_PASSED
+ALIAS: GL_BLEND_EQUATION_RGB gl:GL_BLEND_EQUATION_RGB
+ALIAS: GL_VERTEX_ATTRIB_ARRAY_ENABLED gl:GL_VERTEX_ATTRIB_ARRAY_ENABLED
+ALIAS: GL_VERTEX_ATTRIB_ARRAY_SIZE gl:GL_VERTEX_ATTRIB_ARRAY_SIZE
+ALIAS: GL_VERTEX_ATTRIB_ARRAY_STRIDE gl:GL_VERTEX_ATTRIB_ARRAY_STRIDE
+ALIAS: GL_VERTEX_ATTRIB_ARRAY_TYPE gl:GL_VERTEX_ATTRIB_ARRAY_TYPE
+ALIAS: GL_CURRENT_VERTEX_ATTRIB gl:GL_CURRENT_VERTEX_ATTRIB
+ALIAS: GL_VERTEX_PROGRAM_POINT_SIZE gl:GL_VERTEX_PROGRAM_POINT_SIZE
+ALIAS: GL_VERTEX_ATTRIB_ARRAY_POINTER gl:GL_VERTEX_ATTRIB_ARRAY_POINTER
+ALIAS: GL_STENCIL_BACK_FUNC gl:GL_STENCIL_BACK_FUNC
+ALIAS: GL_STENCIL_BACK_FAIL gl:GL_STENCIL_BACK_FAIL
+ALIAS: GL_STENCIL_BACK_PASS_DEPTH_FAIL gl:GL_STENCIL_BACK_PASS_DEPTH_FAIL
+ALIAS: GL_STENCIL_BACK_PASS_DEPTH_PASS gl:GL_STENCIL_BACK_PASS_DEPTH_PASS
+ALIAS: GL_MAX_DRAW_BUFFERS gl:GL_MAX_DRAW_BUFFERS
+ALIAS: GL_DRAW_BUFFER0 gl:GL_DRAW_BUFFER0
+ALIAS: GL_DRAW_BUFFER1 gl:GL_DRAW_BUFFER1
+ALIAS: GL_DRAW_BUFFER2 gl:GL_DRAW_BUFFER2
+ALIAS: GL_DRAW_BUFFER3 gl:GL_DRAW_BUFFER3
+ALIAS: GL_DRAW_BUFFER4 gl:GL_DRAW_BUFFER4
+ALIAS: GL_DRAW_BUFFER5 gl:GL_DRAW_BUFFER5
+ALIAS: GL_DRAW_BUFFER6 gl:GL_DRAW_BUFFER6
+ALIAS: GL_DRAW_BUFFER7 gl:GL_DRAW_BUFFER7
+ALIAS: GL_DRAW_BUFFER8 gl:GL_DRAW_BUFFER8
+ALIAS: GL_DRAW_BUFFER9 gl:GL_DRAW_BUFFER9
+ALIAS: GL_DRAW_BUFFER10 gl:GL_DRAW_BUFFER10
+ALIAS: GL_DRAW_BUFFER11 gl:GL_DRAW_BUFFER11
+ALIAS: GL_DRAW_BUFFER12 gl:GL_DRAW_BUFFER12
+ALIAS: GL_DRAW_BUFFER13 gl:GL_DRAW_BUFFER13
+ALIAS: GL_DRAW_BUFFER14 gl:GL_DRAW_BUFFER14
+ALIAS: GL_DRAW_BUFFER15 gl:GL_DRAW_BUFFER15
+ALIAS: GL_BLEND_EQUATION_ALPHA gl:GL_BLEND_EQUATION_ALPHA
+ALIAS: GL_MAX_VERTEX_ATTRIBS gl:GL_MAX_VERTEX_ATTRIBS
+ALIAS: GL_VERTEX_ATTRIB_ARRAY_NORMALIZED gl:GL_VERTEX_ATTRIB_ARRAY_NORMALIZED
+ALIAS: GL_MAX_TEXTURE_IMAGE_UNITS gl:GL_MAX_TEXTURE_IMAGE_UNITS
+ALIAS: GL_FRAGMENT_SHADER gl:GL_FRAGMENT_SHADER
+ALIAS: GL_VERTEX_SHADER gl:GL_VERTEX_SHADER
+ALIAS: GL_MAX_FRAGMENT_UNIFORM_COMPONENTS gl:GL_MAX_FRAGMENT_UNIFORM_COMPONENTS
+ALIAS: GL_MAX_VERTEX_UNIFORM_COMPONENTS gl:GL_MAX_VERTEX_UNIFORM_COMPONENTS
+ALIAS: GL_MAX_VARYING_FLOATS gl:GL_MAX_VARYING_FLOATS
+ALIAS: GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS gl:GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS
+ALIAS: GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS gl:GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS
+ALIAS: GL_SHADER_TYPE gl:GL_SHADER_TYPE
+ALIAS: GL_FLOAT_VEC2 gl:GL_FLOAT_VEC2
+ALIAS: GL_FLOAT_VEC3 gl:GL_FLOAT_VEC3
+ALIAS: GL_FLOAT_VEC4 gl:GL_FLOAT_VEC4
+ALIAS: GL_INT_VEC2 gl:GL_INT_VEC2
+ALIAS: GL_INT_VEC3 gl:GL_INT_VEC3
+ALIAS: GL_INT_VEC4 gl:GL_INT_VEC4
+ALIAS: GL_BOOL gl:GL_BOOL
+ALIAS: GL_BOOL_VEC2 gl:GL_BOOL_VEC2
+ALIAS: GL_BOOL_VEC3 gl:GL_BOOL_VEC3
+ALIAS: GL_BOOL_VEC4 gl:GL_BOOL_VEC4
+ALIAS: GL_FLOAT_MAT2 gl:GL_FLOAT_MAT2
+ALIAS: GL_FLOAT_MAT3 gl:GL_FLOAT_MAT3
+ALIAS: GL_FLOAT_MAT4 gl:GL_FLOAT_MAT4
+ALIAS: GL_SAMPLER_1D gl:GL_SAMPLER_1D
+ALIAS: GL_SAMPLER_2D gl:GL_SAMPLER_2D
+ALIAS: GL_SAMPLER_3D gl:GL_SAMPLER_3D
+ALIAS: GL_SAMPLER_CUBE gl:GL_SAMPLER_CUBE
+ALIAS: GL_SAMPLER_1D_SHADOW gl:GL_SAMPLER_1D_SHADOW
+ALIAS: GL_SAMPLER_2D_SHADOW gl:GL_SAMPLER_2D_SHADOW
+ALIAS: GL_DELETE_STATUS gl:GL_DELETE_STATUS
+ALIAS: GL_COMPILE_STATUS gl:GL_COMPILE_STATUS
+ALIAS: GL_LINK_STATUS gl:GL_LINK_STATUS
+ALIAS: GL_VALIDATE_STATUS gl:GL_VALIDATE_STATUS
+ALIAS: GL_INFO_LOG_LENGTH gl:GL_INFO_LOG_LENGTH
+ALIAS: GL_ATTACHED_SHADERS gl:GL_ATTACHED_SHADERS
+ALIAS: GL_ACTIVE_UNIFORMS gl:GL_ACTIVE_UNIFORMS
+ALIAS: GL_ACTIVE_UNIFORM_MAX_LENGTH gl:GL_ACTIVE_UNIFORM_MAX_LENGTH
+ALIAS: GL_SHADER_SOURCE_LENGTH gl:GL_SHADER_SOURCE_LENGTH
+ALIAS: GL_ACTIVE_ATTRIBUTES gl:GL_ACTIVE_ATTRIBUTES
+ALIAS: GL_ACTIVE_ATTRIBUTE_MAX_LENGTH gl:GL_ACTIVE_ATTRIBUTE_MAX_LENGTH
+ALIAS: GL_FRAGMENT_SHADER_DERIVATIVE_HINT gl:GL_FRAGMENT_SHADER_DERIVATIVE_HINT
+ALIAS: GL_SHADING_LANGUAGE_VERSION gl:GL_SHADING_LANGUAGE_VERSION
+ALIAS: GL_CURRENT_PROGRAM gl:GL_CURRENT_PROGRAM
+ALIAS: GL_POINT_SPRITE_COORD_ORIGIN gl:GL_POINT_SPRITE_COORD_ORIGIN
+ALIAS: GL_LOWER_LEFT gl:GL_LOWER_LEFT
+ALIAS: GL_UPPER_LEFT gl:GL_UPPER_LEFT
+ALIAS: GL_STENCIL_BACK_REF gl:GL_STENCIL_BACK_REF
+ALIAS: GL_STENCIL_BACK_VALUE_MASK gl:GL_STENCIL_BACK_VALUE_MASK
+ALIAS: GL_STENCIL_BACK_WRITEMASK gl:GL_STENCIL_BACK_WRITEMASK
+ALIAS: GL_PIXEL_PACK_BUFFER gl:GL_PIXEL_PACK_BUFFER
+ALIAS: GL_PIXEL_UNPACK_BUFFER gl:GL_PIXEL_UNPACK_BUFFER
+ALIAS: GL_PIXEL_PACK_BUFFER_BINDING gl:GL_PIXEL_PACK_BUFFER_BINDING
+ALIAS: GL_PIXEL_UNPACK_BUFFER_BINDING gl:GL_PIXEL_UNPACK_BUFFER_BINDING
+ALIAS: GL_FLOAT_MAT2x3 gl:GL_FLOAT_MAT2x3
+ALIAS: GL_FLOAT_MAT2x4 gl:GL_FLOAT_MAT2x4
+ALIAS: GL_FLOAT_MAT3x2 gl:GL_FLOAT_MAT3x2
+ALIAS: GL_FLOAT_MAT3x4 gl:GL_FLOAT_MAT3x4
+ALIAS: GL_FLOAT_MAT4x2 gl:GL_FLOAT_MAT4x2
+ALIAS: GL_FLOAT_MAT4x3 gl:GL_FLOAT_MAT4x3
+ALIAS: GL_SRGB gl:GL_SRGB
+ALIAS: GL_SRGB8 gl:GL_SRGB8
+ALIAS: GL_SRGB_ALPHA gl:GL_SRGB_ALPHA
+ALIAS: GL_SRGB8_ALPHA8 gl:GL_SRGB8_ALPHA8
+ALIAS: GL_COMPRESSED_SRGB gl:GL_COMPRESSED_SRGB
+ALIAS: GL_COMPRESSED_SRGB_ALPHA gl:GL_COMPRESSED_SRGB_ALPHA
+ALIAS: GL_COMPARE_REF_TO_TEXTURE gl:GL_COMPARE_REF_TO_TEXTURE
+ALIAS: GL_CLIP_DISTANCE0 gl:GL_CLIP_DISTANCE0
+ALIAS: GL_CLIP_DISTANCE1 gl:GL_CLIP_DISTANCE1
+ALIAS: GL_CLIP_DISTANCE2 gl:GL_CLIP_DISTANCE2
+ALIAS: GL_CLIP_DISTANCE3 gl:GL_CLIP_DISTANCE3
+ALIAS: GL_CLIP_DISTANCE4 gl:GL_CLIP_DISTANCE4
+ALIAS: GL_CLIP_DISTANCE5 gl:GL_CLIP_DISTANCE5
+ALIAS: GL_MAX_CLIP_DISTANCES gl:GL_MAX_CLIP_DISTANCES
+ALIAS: GL_MAJOR_VERSION gl:GL_MAJOR_VERSION
+ALIAS: GL_MINOR_VERSION gl:GL_MINOR_VERSION
+ALIAS: GL_NUM_EXTENSIONS gl:GL_NUM_EXTENSIONS
+ALIAS: GL_CONTEXT_FLAGS gl:GL_CONTEXT_FLAGS
+ALIAS: GL_DEPTH_BUFFER gl:GL_DEPTH_BUFFER
+ALIAS: GL_STENCIL_BUFFER gl:GL_STENCIL_BUFFER
+ALIAS: GL_COMPRESSED_RED gl:GL_COMPRESSED_RED
+ALIAS: GL_COMPRESSED_RG gl:GL_COMPRESSED_RG
+ALIAS: GL_CONTEXT_FLAG_FORWARD_COMPATIBLE_BIT gl:GL_CONTEXT_FLAG_FORWARD_COMPATIBLE_BIT
+ALIAS: GL_RGBA32F gl:GL_RGBA32F
+ALIAS: GL_RGB32F gl:GL_RGB32F
+ALIAS: GL_RGBA16F gl:GL_RGBA16F
+ALIAS: GL_RGB16F gl:GL_RGB16F
+ALIAS: GL_VERTEX_ATTRIB_ARRAY_INTEGER gl:GL_VERTEX_ATTRIB_ARRAY_INTEGER
+ALIAS: GL_MAX_ARRAY_TEXTURE_LAYERS gl:GL_MAX_ARRAY_TEXTURE_LAYERS
+ALIAS: GL_MIN_PROGRAM_TEXEL_OFFSET gl:GL_MIN_PROGRAM_TEXEL_OFFSET
+ALIAS: GL_MAX_PROGRAM_TEXEL_OFFSET gl:GL_MAX_PROGRAM_TEXEL_OFFSET
+ALIAS: GL_CLAMP_READ_COLOR gl:GL_CLAMP_READ_COLOR
+ALIAS: GL_FIXED_ONLY gl:GL_FIXED_ONLY
+ALIAS: GL_MAX_VARYING_COMPONENTS gl:GL_MAX_VARYING_COMPONENTS
+ALIAS: GL_TEXTURE_1D_ARRAY gl:GL_TEXTURE_1D_ARRAY
+ALIAS: GL_PROXY_TEXTURE_1D_ARRAY gl:GL_PROXY_TEXTURE_1D_ARRAY
+ALIAS: GL_TEXTURE_2D_ARRAY gl:GL_TEXTURE_2D_ARRAY
+ALIAS: GL_PROXY_TEXTURE_2D_ARRAY gl:GL_PROXY_TEXTURE_2D_ARRAY
+ALIAS: GL_TEXTURE_BINDING_1D_ARRAY gl:GL_TEXTURE_BINDING_1D_ARRAY
+ALIAS: GL_TEXTURE_BINDING_2D_ARRAY gl:GL_TEXTURE_BINDING_2D_ARRAY
+ALIAS: GL_R11F_G11F_B10F gl:GL_R11F_G11F_B10F
+ALIAS: GL_UNSIGNED_INT_10F_11F_11F_REV gl:GL_UNSIGNED_INT_10F_11F_11F_REV
+ALIAS: GL_RGB9_E5 gl:GL_RGB9_E5
+ALIAS: GL_UNSIGNED_INT_5_9_9_9_REV gl:GL_UNSIGNED_INT_5_9_9_9_REV
+ALIAS: GL_TEXTURE_SHARED_SIZE gl:GL_TEXTURE_SHARED_SIZE
+ALIAS: GL_TRANSFORM_FEEDBACK_VARYING_MAX_LENGTH gl:GL_TRANSFORM_FEEDBACK_VARYING_MAX_LENGTH
+ALIAS: GL_TRANSFORM_FEEDBACK_BUFFER_MODE gl:GL_TRANSFORM_FEEDBACK_BUFFER_MODE
+ALIAS: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS gl:GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS
+ALIAS: GL_TRANSFORM_FEEDBACK_VARYINGS gl:GL_TRANSFORM_FEEDBACK_VARYINGS
+ALIAS: GL_TRANSFORM_FEEDBACK_BUFFER_START gl:GL_TRANSFORM_FEEDBACK_BUFFER_START
+ALIAS: GL_TRANSFORM_FEEDBACK_BUFFER_SIZE gl:GL_TRANSFORM_FEEDBACK_BUFFER_SIZE
+ALIAS: GL_PRIMITIVES_GENERATED gl:GL_PRIMITIVES_GENERATED
+ALIAS: GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN gl:GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN
+ALIAS: GL_RASTERIZER_DISCARD gl:GL_RASTERIZER_DISCARD
+ALIAS: GL_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS gl:GL_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS
+ALIAS: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS gl:GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS
+ALIAS: GL_INTERLEAVED_ATTRIBS gl:GL_INTERLEAVED_ATTRIBS
+ALIAS: GL_SEPARATE_ATTRIBS gl:GL_SEPARATE_ATTRIBS
+ALIAS: GL_TRANSFORM_FEEDBACK_BUFFER gl:GL_TRANSFORM_FEEDBACK_BUFFER
+ALIAS: GL_TRANSFORM_FEEDBACK_BUFFER_BINDING gl:GL_TRANSFORM_FEEDBACK_BUFFER_BINDING
+ALIAS: GL_RGBA32UI gl:GL_RGBA32UI
+ALIAS: GL_RGB32UI gl:GL_RGB32UI
+ALIAS: GL_RGBA16UI gl:GL_RGBA16UI
+ALIAS: GL_RGB16UI gl:GL_RGB16UI
+ALIAS: GL_RGBA8UI gl:GL_RGBA8UI
+ALIAS: GL_RGB8UI gl:GL_RGB8UI
+ALIAS: GL_RGBA32I gl:GL_RGBA32I
+ALIAS: GL_RGB32I gl:GL_RGB32I
+ALIAS: GL_RGBA16I gl:GL_RGBA16I
+ALIAS: GL_RGB16I gl:GL_RGB16I
+ALIAS: GL_RGBA8I gl:GL_RGBA8I
+ALIAS: GL_RGB8I gl:GL_RGB8I
+ALIAS: GL_RED_INTEGER gl:GL_RED_INTEGER
+ALIAS: GL_GREEN_INTEGER gl:GL_GREEN_INTEGER
+ALIAS: GL_BLUE_INTEGER gl:GL_BLUE_INTEGER
+ALIAS: GL_RGB_INTEGER gl:GL_RGB_INTEGER
+ALIAS: GL_RGBA_INTEGER gl:GL_RGBA_INTEGER
+ALIAS: GL_BGR_INTEGER gl:GL_BGR_INTEGER
+ALIAS: GL_BGRA_INTEGER gl:GL_BGRA_INTEGER
+ALIAS: GL_SAMPLER_1D_ARRAY gl:GL_SAMPLER_1D_ARRAY
+ALIAS: GL_SAMPLER_2D_ARRAY gl:GL_SAMPLER_2D_ARRAY
+ALIAS: GL_SAMPLER_1D_ARRAY_SHADOW gl:GL_SAMPLER_1D_ARRAY_SHADOW
+ALIAS: GL_SAMPLER_2D_ARRAY_SHADOW gl:GL_SAMPLER_2D_ARRAY_SHADOW
+ALIAS: GL_SAMPLER_CUBE_SHADOW gl:GL_SAMPLER_CUBE_SHADOW
+ALIAS: GL_UNSIGNED_INT_VEC2 gl:GL_UNSIGNED_INT_VEC2
+ALIAS: GL_UNSIGNED_INT_VEC3 gl:GL_UNSIGNED_INT_VEC3
+ALIAS: GL_UNSIGNED_INT_VEC4 gl:GL_UNSIGNED_INT_VEC4
+ALIAS: GL_INT_SAMPLER_1D gl:GL_INT_SAMPLER_1D
+ALIAS: GL_INT_SAMPLER_2D gl:GL_INT_SAMPLER_2D
+ALIAS: GL_INT_SAMPLER_3D gl:GL_INT_SAMPLER_3D
+ALIAS: GL_INT_SAMPLER_CUBE gl:GL_INT_SAMPLER_CUBE
+ALIAS: GL_INT_SAMPLER_1D_ARRAY gl:GL_INT_SAMPLER_1D_ARRAY
+ALIAS: GL_INT_SAMPLER_2D_ARRAY gl:GL_INT_SAMPLER_2D_ARRAY
+ALIAS: GL_UNSIGNED_INT_SAMPLER_1D gl:GL_UNSIGNED_INT_SAMPLER_1D
+ALIAS: GL_UNSIGNED_INT_SAMPLER_2D gl:GL_UNSIGNED_INT_SAMPLER_2D
+ALIAS: GL_UNSIGNED_INT_SAMPLER_3D gl:GL_UNSIGNED_INT_SAMPLER_3D
+ALIAS: GL_UNSIGNED_INT_SAMPLER_CUBE gl:GL_UNSIGNED_INT_SAMPLER_CUBE
+ALIAS: GL_UNSIGNED_INT_SAMPLER_1D_ARRAY gl:GL_UNSIGNED_INT_SAMPLER_1D_ARRAY
+ALIAS: GL_UNSIGNED_INT_SAMPLER_2D_ARRAY gl:GL_UNSIGNED_INT_SAMPLER_2D_ARRAY
+ALIAS: GL_QUERY_WAIT gl:GL_QUERY_WAIT
+ALIAS: GL_QUERY_NO_WAIT gl:GL_QUERY_NO_WAIT
+ALIAS: GL_QUERY_BY_REGION_WAIT gl:GL_QUERY_BY_REGION_WAIT
+ALIAS: GL_QUERY_BY_REGION_NO_WAIT gl:GL_QUERY_BY_REGION_NO_WAIT
+ALIAS: GL_DEPTH_COMPONENT32F gl:GL_DEPTH_COMPONENT32F
+ALIAS: GL_DEPTH32F_STENCIL8 gl:GL_DEPTH32F_STENCIL8
+ALIAS: GL_FLOAT_32_UNSIGNED_INT_24_8_REV gl:GL_FLOAT_32_UNSIGNED_INT_24_8_REV
+ALIAS: GL_INVALID_FRAMEBUFFER_OPERATION gl:GL_INVALID_FRAMEBUFFER_OPERATION
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_COLOR_ENCODING gl:GL_FRAMEBUFFER_ATTACHMENT_COLOR_ENCODING
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_COMPONENT_TYPE gl:GL_FRAMEBUFFER_ATTACHMENT_COMPONENT_TYPE
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_RED_SIZE gl:GL_FRAMEBUFFER_ATTACHMENT_RED_SIZE
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_GREEN_SIZE gl:GL_FRAMEBUFFER_ATTACHMENT_GREEN_SIZE
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_BLUE_SIZE gl:GL_FRAMEBUFFER_ATTACHMENT_BLUE_SIZE
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_ALPHA_SIZE gl:GL_FRAMEBUFFER_ATTACHMENT_ALPHA_SIZE
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_DEPTH_SIZE gl:GL_FRAMEBUFFER_ATTACHMENT_DEPTH_SIZE
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_STENCIL_SIZE gl:GL_FRAMEBUFFER_ATTACHMENT_STENCIL_SIZE
+ALIAS: GL_FRAMEBUFFER_DEFAULT gl:GL_FRAMEBUFFER_DEFAULT
+ALIAS: GL_FRAMEBUFFER_UNDEFINED gl:GL_FRAMEBUFFER_UNDEFINED
+ALIAS: GL_DEPTH_STENCIL_ATTACHMENT gl:GL_DEPTH_STENCIL_ATTACHMENT
+ALIAS: GL_INDEX gl:GL_INDEX
+ALIAS: GL_MAX_RENDERBUFFER_SIZE gl:GL_MAX_RENDERBUFFER_SIZE
+ALIAS: GL_DEPTH_STENCIL gl:GL_DEPTH_STENCIL
+ALIAS: GL_UNSIGNED_INT_24_8 gl:GL_UNSIGNED_INT_24_8
+ALIAS: GL_DEPTH24_STENCIL8 gl:GL_DEPTH24_STENCIL8
+ALIAS: GL_TEXTURE_STENCIL_SIZE gl:GL_TEXTURE_STENCIL_SIZE
+ALIAS: GL_TEXTURE_RED_TYPE gl:GL_TEXTURE_RED_TYPE
+ALIAS: GL_TEXTURE_GREEN_TYPE gl:GL_TEXTURE_GREEN_TYPE
+ALIAS: GL_TEXTURE_BLUE_TYPE gl:GL_TEXTURE_BLUE_TYPE
+ALIAS: GL_TEXTURE_ALPHA_TYPE gl:GL_TEXTURE_ALPHA_TYPE
+ALIAS: GL_TEXTURE_DEPTH_TYPE gl:GL_TEXTURE_DEPTH_TYPE
+ALIAS: GL_UNSIGNED_NORMALIZED gl:GL_UNSIGNED_NORMALIZED
+ALIAS: GL_FRAMEBUFFER_BINDING gl:GL_FRAMEBUFFER_BINDING
+ALIAS: GL_DRAW_FRAMEBUFFER_BINDING gl:GL_DRAW_FRAMEBUFFER_BINDING
+ALIAS: GL_RENDERBUFFER_BINDING gl:GL_RENDERBUFFER_BINDING
+ALIAS: GL_READ_FRAMEBUFFER gl:GL_READ_FRAMEBUFFER
+ALIAS: GL_DRAW_FRAMEBUFFER gl:GL_DRAW_FRAMEBUFFER
+ALIAS: GL_READ_FRAMEBUFFER_BINDING gl:GL_READ_FRAMEBUFFER_BINDING
+ALIAS: GL_RENDERBUFFER_SAMPLES gl:GL_RENDERBUFFER_SAMPLES
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE gl:GL_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME gl:GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL gl:GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE gl:GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LAYER gl:GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LAYER
+ALIAS: GL_FRAMEBUFFER_COMPLETE gl:GL_FRAMEBUFFER_COMPLETE
+ALIAS: GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT gl:GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT
+ALIAS: GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT gl:GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT
+ALIAS: GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER gl:GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER
+ALIAS: GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER gl:GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER
+ALIAS: GL_FRAMEBUFFER_UNSUPPORTED gl:GL_FRAMEBUFFER_UNSUPPORTED
+ALIAS: GL_MAX_COLOR_ATTACHMENTS gl:GL_MAX_COLOR_ATTACHMENTS
+ALIAS: GL_COLOR_ATTACHMENT0 gl:GL_COLOR_ATTACHMENT0
+ALIAS: GL_COLOR_ATTACHMENT1 gl:GL_COLOR_ATTACHMENT1
+ALIAS: GL_COLOR_ATTACHMENT2 gl:GL_COLOR_ATTACHMENT2
+ALIAS: GL_COLOR_ATTACHMENT3 gl:GL_COLOR_ATTACHMENT3
+ALIAS: GL_COLOR_ATTACHMENT4 gl:GL_COLOR_ATTACHMENT4
+ALIAS: GL_COLOR_ATTACHMENT5 gl:GL_COLOR_ATTACHMENT5
+ALIAS: GL_COLOR_ATTACHMENT6 gl:GL_COLOR_ATTACHMENT6
+ALIAS: GL_COLOR_ATTACHMENT7 gl:GL_COLOR_ATTACHMENT7
+ALIAS: GL_COLOR_ATTACHMENT8 gl:GL_COLOR_ATTACHMENT8
+ALIAS: GL_COLOR_ATTACHMENT9 gl:GL_COLOR_ATTACHMENT9
+ALIAS: GL_COLOR_ATTACHMENT10 gl:GL_COLOR_ATTACHMENT10
+ALIAS: GL_COLOR_ATTACHMENT11 gl:GL_COLOR_ATTACHMENT11
+ALIAS: GL_COLOR_ATTACHMENT12 gl:GL_COLOR_ATTACHMENT12
+ALIAS: GL_COLOR_ATTACHMENT13 gl:GL_COLOR_ATTACHMENT13
+ALIAS: GL_COLOR_ATTACHMENT14 gl:GL_COLOR_ATTACHMENT14
+ALIAS: GL_COLOR_ATTACHMENT15 gl:GL_COLOR_ATTACHMENT15
+ALIAS: GL_DEPTH_ATTACHMENT gl:GL_DEPTH_ATTACHMENT
+ALIAS: GL_STENCIL_ATTACHMENT gl:GL_STENCIL_ATTACHMENT
+ALIAS: GL_FRAMEBUFFER gl:GL_FRAMEBUFFER
+ALIAS: GL_RENDERBUFFER gl:GL_RENDERBUFFER
+ALIAS: GL_RENDERBUFFER_WIDTH gl:GL_RENDERBUFFER_WIDTH
+ALIAS: GL_RENDERBUFFER_HEIGHT gl:GL_RENDERBUFFER_HEIGHT
+ALIAS: GL_RENDERBUFFER_INTERNAL_FORMAT gl:GL_RENDERBUFFER_INTERNAL_FORMAT
+ALIAS: GL_STENCIL_INDEX1 gl:GL_STENCIL_INDEX1
+ALIAS: GL_STENCIL_INDEX4 gl:GL_STENCIL_INDEX4
+ALIAS: GL_STENCIL_INDEX8 gl:GL_STENCIL_INDEX8
+ALIAS: GL_STENCIL_INDEX16 gl:GL_STENCIL_INDEX16
+ALIAS: GL_RENDERBUFFER_RED_SIZE gl:GL_RENDERBUFFER_RED_SIZE
+ALIAS: GL_RENDERBUFFER_GREEN_SIZE gl:GL_RENDERBUFFER_GREEN_SIZE
+ALIAS: GL_RENDERBUFFER_BLUE_SIZE gl:GL_RENDERBUFFER_BLUE_SIZE
+ALIAS: GL_RENDERBUFFER_ALPHA_SIZE gl:GL_RENDERBUFFER_ALPHA_SIZE
+ALIAS: GL_RENDERBUFFER_DEPTH_SIZE gl:GL_RENDERBUFFER_DEPTH_SIZE
+ALIAS: GL_RENDERBUFFER_STENCIL_SIZE gl:GL_RENDERBUFFER_STENCIL_SIZE
+ALIAS: GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE gl:GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE
+ALIAS: GL_MAX_SAMPLES gl:GL_MAX_SAMPLES
+ALIAS: GL_FRAMEBUFFER_SRGB gl:GL_FRAMEBUFFER_SRGB
+ALIAS: GL_HALF_FLOAT gl:GL_HALF_FLOAT
+ALIAS: GL_MAP_READ_BIT gl:GL_MAP_READ_BIT
+ALIAS: GL_MAP_WRITE_BIT gl:GL_MAP_WRITE_BIT
+ALIAS: GL_MAP_INVALIDATE_RANGE_BIT gl:GL_MAP_INVALIDATE_RANGE_BIT
+ALIAS: GL_MAP_INVALIDATE_BUFFER_BIT gl:GL_MAP_INVALIDATE_BUFFER_BIT
+ALIAS: GL_MAP_FLUSH_EXPLICIT_BIT gl:GL_MAP_FLUSH_EXPLICIT_BIT
+ALIAS: GL_MAP_UNSYNCHRONIZED_BIT gl:GL_MAP_UNSYNCHRONIZED_BIT
+ALIAS: GL_COMPRESSED_RED_RGTC1 gl:GL_COMPRESSED_RED_RGTC1
+ALIAS: GL_COMPRESSED_SIGNED_RED_RGTC1 gl:GL_COMPRESSED_SIGNED_RED_RGTC1
+ALIAS: GL_COMPRESSED_RG_RGTC2 gl:GL_COMPRESSED_RG_RGTC2
+ALIAS: GL_COMPRESSED_SIGNED_RG_RGTC2 gl:GL_COMPRESSED_SIGNED_RG_RGTC2
+ALIAS: GL_RG gl:GL_RG
+ALIAS: GL_RG_INTEGER gl:GL_RG_INTEGER
+ALIAS: GL_R8 gl:GL_R8
+ALIAS: GL_R16 gl:GL_R16
+ALIAS: GL_RG8 gl:GL_RG8
+ALIAS: GL_RG16 gl:GL_RG16
+ALIAS: GL_R16F gl:GL_R16F
+ALIAS: GL_R32F gl:GL_R32F
+ALIAS: GL_RG16F gl:GL_RG16F
+ALIAS: GL_RG32F gl:GL_RG32F
+ALIAS: GL_R8I gl:GL_R8I
+ALIAS: GL_R8UI gl:GL_R8UI
+ALIAS: GL_R16I gl:GL_R16I
+ALIAS: GL_R16UI gl:GL_R16UI
+ALIAS: GL_R32I gl:GL_R32I
+ALIAS: GL_R32UI gl:GL_R32UI
+ALIAS: GL_RG8I gl:GL_RG8I
+ALIAS: GL_RG8UI gl:GL_RG8UI
+ALIAS: GL_RG16I gl:GL_RG16I
+ALIAS: GL_RG16UI gl:GL_RG16UI
+ALIAS: GL_RG32I gl:GL_RG32I
+ALIAS: GL_RG32UI gl:GL_RG32UI
+ALIAS: GL_VERTEX_ARRAY_BINDING gl:GL_VERTEX_ARRAY_BINDING
+ALIAS: GL_SAMPLER_2D_RECT gl:GL_SAMPLER_2D_RECT
+ALIAS: GL_SAMPLER_2D_RECT_SHADOW gl:GL_SAMPLER_2D_RECT_SHADOW
+ALIAS: GL_SAMPLER_BUFFER gl:GL_SAMPLER_BUFFER
+ALIAS: GL_INT_SAMPLER_2D_RECT gl:GL_INT_SAMPLER_2D_RECT
+ALIAS: GL_INT_SAMPLER_BUFFER gl:GL_INT_SAMPLER_BUFFER
+ALIAS: GL_UNSIGNED_INT_SAMPLER_2D_RECT gl:GL_UNSIGNED_INT_SAMPLER_2D_RECT
+ALIAS: GL_UNSIGNED_INT_SAMPLER_BUFFER gl:GL_UNSIGNED_INT_SAMPLER_BUFFER
+ALIAS: GL_TEXTURE_BUFFER gl:GL_TEXTURE_BUFFER
+ALIAS: GL_MAX_TEXTURE_BUFFER_SIZE gl:GL_MAX_TEXTURE_BUFFER_SIZE
+ALIAS: GL_TEXTURE_BINDING_BUFFER gl:GL_TEXTURE_BINDING_BUFFER
+ALIAS: GL_TEXTURE_BUFFER_DATA_STORE_BINDING gl:GL_TEXTURE_BUFFER_DATA_STORE_BINDING
+ALIAS: GL_TEXTURE_BUFFER_FORMAT gl:GL_TEXTURE_BUFFER_FORMAT
+ALIAS: GL_TEXTURE_RECTANGLE gl:GL_TEXTURE_RECTANGLE
+ALIAS: GL_TEXTURE_BINDING_RECTANGLE gl:GL_TEXTURE_BINDING_RECTANGLE
+ALIAS: GL_PROXY_TEXTURE_RECTANGLE gl:GL_PROXY_TEXTURE_RECTANGLE
+ALIAS: GL_MAX_RECTANGLE_TEXTURE_SIZE gl:GL_MAX_RECTANGLE_TEXTURE_SIZE
+ALIAS: GL_RED_SNORM gl:GL_RED_SNORM
+ALIAS: GL_RG_SNORM gl:GL_RG_SNORM
+ALIAS: GL_RGB_SNORM gl:GL_RGB_SNORM
+ALIAS: GL_RGBA_SNORM gl:GL_RGBA_SNORM
+ALIAS: GL_R8_SNORM gl:GL_R8_SNORM
+ALIAS: GL_RG8_SNORM gl:GL_RG8_SNORM
+ALIAS: GL_RGB8_SNORM gl:GL_RGB8_SNORM
+ALIAS: GL_RGBA8_SNORM gl:GL_RGBA8_SNORM
+ALIAS: GL_R16_SNORM gl:GL_R16_SNORM
+ALIAS: GL_RG16_SNORM gl:GL_RG16_SNORM
+ALIAS: GL_RGB16_SNORM gl:GL_RGB16_SNORM
+ALIAS: GL_RGBA16_SNORM gl:GL_RGBA16_SNORM
+ALIAS: GL_SIGNED_NORMALIZED gl:GL_SIGNED_NORMALIZED
+ALIAS: GL_PRIMITIVE_RESTART gl:GL_PRIMITIVE_RESTART
+ALIAS: GL_PRIMITIVE_RESTART_INDEX gl:GL_PRIMITIVE_RESTART_INDEX
+ALIAS: GL_COPY_READ_BUFFER gl:GL_COPY_READ_BUFFER
+ALIAS: GL_COPY_WRITE_BUFFER gl:GL_COPY_WRITE_BUFFER
+ALIAS: GL_UNIFORM_BUFFER gl:GL_UNIFORM_BUFFER
+ALIAS: GL_UNIFORM_BUFFER_BINDING gl:GL_UNIFORM_BUFFER_BINDING
+ALIAS: GL_UNIFORM_BUFFER_START gl:GL_UNIFORM_BUFFER_START
+ALIAS: GL_UNIFORM_BUFFER_SIZE gl:GL_UNIFORM_BUFFER_SIZE
+ALIAS: GL_MAX_VERTEX_UNIFORM_BLOCKS gl:GL_MAX_VERTEX_UNIFORM_BLOCKS
+ALIAS: GL_MAX_FRAGMENT_UNIFORM_BLOCKS gl:GL_MAX_FRAGMENT_UNIFORM_BLOCKS
+ALIAS: GL_MAX_COMBINED_UNIFORM_BLOCKS gl:GL_MAX_COMBINED_UNIFORM_BLOCKS
+ALIAS: GL_MAX_UNIFORM_BUFFER_BINDINGS gl:GL_MAX_UNIFORM_BUFFER_BINDINGS
+ALIAS: GL_MAX_UNIFORM_BLOCK_SIZE gl:GL_MAX_UNIFORM_BLOCK_SIZE
+ALIAS: GL_MAX_COMBINED_VERTEX_UNIFORM_COMPONENTS gl:GL_MAX_COMBINED_VERTEX_UNIFORM_COMPONENTS
+ALIAS: GL_MAX_COMBINED_FRAGMENT_UNIFORM_COMPONENTS gl:GL_MAX_COMBINED_FRAGMENT_UNIFORM_COMPONENTS
+ALIAS: GL_UNIFORM_BUFFER_OFFSET_ALIGNMENT gl:GL_UNIFORM_BUFFER_OFFSET_ALIGNMENT
+ALIAS: GL_ACTIVE_UNIFORM_BLOCK_MAX_NAME_LENGTH gl:GL_ACTIVE_UNIFORM_BLOCK_MAX_NAME_LENGTH
+ALIAS: GL_ACTIVE_UNIFORM_BLOCKS gl:GL_ACTIVE_UNIFORM_BLOCKS
+ALIAS: GL_UNIFORM_TYPE gl:GL_UNIFORM_TYPE
+ALIAS: GL_UNIFORM_SIZE gl:GL_UNIFORM_SIZE
+ALIAS: GL_UNIFORM_NAME_LENGTH gl:GL_UNIFORM_NAME_LENGTH
+ALIAS: GL_UNIFORM_BLOCK_INDEX gl:GL_UNIFORM_BLOCK_INDEX
+ALIAS: GL_UNIFORM_OFFSET gl:GL_UNIFORM_OFFSET
+ALIAS: GL_UNIFORM_ARRAY_STRIDE gl:GL_UNIFORM_ARRAY_STRIDE
+ALIAS: GL_UNIFORM_MATRIX_STRIDE gl:GL_UNIFORM_MATRIX_STRIDE
+ALIAS: GL_UNIFORM_IS_ROW_MAJOR gl:GL_UNIFORM_IS_ROW_MAJOR
+ALIAS: GL_UNIFORM_BLOCK_BINDING gl:GL_UNIFORM_BLOCK_BINDING
+ALIAS: GL_UNIFORM_BLOCK_DATA_SIZE gl:GL_UNIFORM_BLOCK_DATA_SIZE
+ALIAS: GL_UNIFORM_BLOCK_NAME_LENGTH gl:GL_UNIFORM_BLOCK_NAME_LENGTH
+ALIAS: GL_UNIFORM_BLOCK_ACTIVE_UNIFORMS gl:GL_UNIFORM_BLOCK_ACTIVE_UNIFORMS
+ALIAS: GL_UNIFORM_BLOCK_ACTIVE_UNIFORM_INDICES gl:GL_UNIFORM_BLOCK_ACTIVE_UNIFORM_INDICES
+ALIAS: GL_UNIFORM_BLOCK_REFERENCED_BY_VERTEX_SHADER gl:GL_UNIFORM_BLOCK_REFERENCED_BY_VERTEX_SHADER
+ALIAS: GL_UNIFORM_BLOCK_REFERENCED_BY_FRAGMENT_SHADER gl:GL_UNIFORM_BLOCK_REFERENCED_BY_FRAGMENT_SHADER
+ALIAS: GL_INVALID_INDEX gl:GL_INVALID_INDEX
+
+ALIAS: glCullFace gl:glCullFace
+ALIAS: glFrontFace gl:glFrontFace
+ALIAS: glHint gl:glHint
+ALIAS: glLineWidth gl:glLineWidth
+ALIAS: glPointSize gl:glPointSize
+ALIAS: glPolygonMode gl:glPolygonMode
+ALIAS: glScissor gl:glScissor
+ALIAS: glTexParameterf gl:glTexParameterf
+ALIAS: glTexParameterfv gl:glTexParameterfv
+ALIAS: glTexParameteri gl:glTexParameteri
+ALIAS: glTexParameteriv gl:glTexParameteriv
+ALIAS: glTexImage1D gl:glTexImage1D
+ALIAS: glTexImage2D gl:glTexImage2D
+ALIAS: glDrawBuffer gl:glDrawBuffer
+ALIAS: glClear gl:glClear
+ALIAS: glClearColor gl:glClearColor
+ALIAS: glClearStencil gl:glClearStencil
+ALIAS: glClearDepth gl:glClearDepth
+ALIAS: glStencilMask gl:glStencilMask
+ALIAS: glColorMask gl:glColorMask
+ALIAS: glDepthMask gl:glDepthMask
+ALIAS: glDisable gl:glDisable
+ALIAS: glEnable gl:glEnable
+ALIAS: glFinish gl:glFinish
+ALIAS: glFlush gl:glFlush
+ALIAS: glBlendFunc gl:glBlendFunc
+ALIAS: glLogicOp gl:glLogicOp
+ALIAS: glStencilFunc gl:glStencilFunc
+ALIAS: glStencilOp gl:glStencilOp
+ALIAS: glDepthFunc gl:glDepthFunc
+ALIAS: glPixelStoref gl:glPixelStoref
+ALIAS: glPixelStorei gl:glPixelStorei
+ALIAS: glReadBuffer gl:glReadBuffer
+ALIAS: glReadPixels gl:glReadPixels
+ALIAS: glGetBooleanv gl:glGetBooleanv
+ALIAS: glGetDoublev gl:glGetDoublev
+ALIAS: glGetError gl:glGetError
+ALIAS: glGetFloatv gl:glGetFloatv
+ALIAS: glGetIntegerv gl:glGetIntegerv
+ALIAS: glGetString gl:glGetString
+ALIAS: glGetTexImage gl:glGetTexImage
+ALIAS: glGetTexParameterfv gl:glGetTexParameterfv
+ALIAS: glGetTexParameteriv gl:glGetTexParameteriv
+ALIAS: glGetTexLevelParameterfv gl:glGetTexLevelParameterfv
+ALIAS: glGetTexLevelParameteriv gl:glGetTexLevelParameteriv
+ALIAS: glIsEnabled gl:glIsEnabled
+ALIAS: glDepthRange gl:glDepthRange
+ALIAS: glViewport gl:glViewport
+ALIAS: glDrawArrays gl:glDrawArrays
+ALIAS: glDrawElements gl:glDrawElements
+ALIAS: glGetPointerv gl:glGetPointerv
+ALIAS: glPolygonOffset gl:glPolygonOffset
+ALIAS: glCopyTexImage1D gl:glCopyTexImage1D
+ALIAS: glCopyTexImage2D gl:glCopyTexImage2D
+ALIAS: glCopyTexSubImage1D gl:glCopyTexSubImage1D
+ALIAS: glCopyTexSubImage2D gl:glCopyTexSubImage2D
+ALIAS: glTexSubImage1D gl:glTexSubImage1D
+ALIAS: glTexSubImage2D gl:glTexSubImage2D
+ALIAS: glBindTexture gl:glBindTexture
+ALIAS: glDeleteTextures gl:glDeleteTextures
+ALIAS: glGenTextures gl:glGenTextures
+ALIAS: glIsTexture gl:glIsTexture
+ALIAS: glBlendColor gl:glBlendColor
+ALIAS: glBlendEquation gl:glBlendEquation
+ALIAS: glDrawRangeElements gl:glDrawRangeElements
+ALIAS: glTexImage3D gl:glTexImage3D
+ALIAS: glTexSubImage3D gl:glTexSubImage3D
+ALIAS: glCopyTexSubImage3D gl:glCopyTexSubImage3D
+ALIAS: glActiveTexture gl:glActiveTexture
+ALIAS: glSampleCoverage gl:glSampleCoverage
+ALIAS: glCompressedTexImage3D gl:glCompressedTexImage3D
+ALIAS: glCompressedTexImage2D gl:glCompressedTexImage2D
+ALIAS: glCompressedTexImage1D gl:glCompressedTexImage1D
+ALIAS: glCompressedTexSubImage3D gl:glCompressedTexSubImage3D
+ALIAS: glCompressedTexSubImage2D gl:glCompressedTexSubImage2D
+ALIAS: glCompressedTexSubImage1D gl:glCompressedTexSubImage1D
+ALIAS: glGetCompressedTexImage gl:glGetCompressedTexImage
+ALIAS: glBlendFuncSeparate gl:glBlendFuncSeparate
+ALIAS: glMultiDrawArrays gl:glMultiDrawArrays
+ALIAS: glMultiDrawElements gl:glMultiDrawElements
+ALIAS: glPointParameterf gl:glPointParameterf
+ALIAS: glPointParameterfv gl:glPointParameterfv
+ALIAS: glPointParameteri gl:glPointParameteri
+ALIAS: glPointParameteriv gl:glPointParameteriv
+ALIAS: glGenQueries gl:glGenQueries
+ALIAS: glDeleteQueries gl:glDeleteQueries
+ALIAS: glIsQuery gl:glIsQuery
+ALIAS: glBeginQuery gl:glBeginQuery
+ALIAS: glEndQuery gl:glEndQuery
+ALIAS: glGetQueryiv gl:glGetQueryiv
+ALIAS: glGetQueryObjectiv gl:glGetQueryObjectiv
+ALIAS: glGetQueryObjectuiv gl:glGetQueryObjectuiv
+ALIAS: glBindBuffer gl:glBindBuffer
+ALIAS: glDeleteBuffers gl:glDeleteBuffers
+ALIAS: glGenBuffers gl:glGenBuffers
+ALIAS: glIsBuffer gl:glIsBuffer
+ALIAS: glBufferData gl:glBufferData
+ALIAS: glBufferSubData gl:glBufferSubData
+ALIAS: glGetBufferSubData gl:glGetBufferSubData
+ALIAS: glMapBuffer gl:glMapBuffer
+ALIAS: glUnmapBuffer gl:glUnmapBuffer
+ALIAS: glGetBufferParameteriv gl:glGetBufferParameteriv
+ALIAS: glGetBufferPointerv gl:glGetBufferPointerv
+ALIAS: glBlendEquationSeparate gl:glBlendEquationSeparate
+ALIAS: glDrawBuffers gl:glDrawBuffers
+ALIAS: glStencilOpSeparate gl:glStencilOpSeparate
+ALIAS: glStencilFuncSeparate gl:glStencilFuncSeparate
+ALIAS: glStencilMaskSeparate gl:glStencilMaskSeparate
+ALIAS: glAttachShader gl:glAttachShader
+ALIAS: glBindAttribLocation gl:glBindAttribLocation
+ALIAS: glCompileShader gl:glCompileShader
+ALIAS: glCreateProgram gl:glCreateProgram
+ALIAS: glCreateShader gl:glCreateShader
+ALIAS: glDeleteProgram gl:glDeleteProgram
+ALIAS: glDeleteShader gl:glDeleteShader
+ALIAS: glDetachShader gl:glDetachShader
+ALIAS: glDisableVertexAttribArray gl:glDisableVertexAttribArray
+ALIAS: glEnableVertexAttribArray gl:glEnableVertexAttribArray
+ALIAS: glGetActiveAttrib gl:glGetActiveAttrib
+ALIAS: glGetActiveUniform gl:glGetActiveUniform
+ALIAS: glGetAttachedShaders gl:glGetAttachedShaders
+ALIAS: glGetAttribLocation gl:glGetAttribLocation
+ALIAS: glGetProgramiv gl:glGetProgramiv
+ALIAS: glGetProgramInfoLog gl:glGetProgramInfoLog
+ALIAS: glGetShaderiv gl:glGetShaderiv
+ALIAS: glGetShaderInfoLog gl:glGetShaderInfoLog
+ALIAS: glGetShaderSource gl:glGetShaderSource
+ALIAS: glGetUniformLocation gl:glGetUniformLocation
+ALIAS: glGetUniformfv gl:glGetUniformfv
+ALIAS: glGetUniformiv gl:glGetUniformiv
+ALIAS: glGetVertexAttribdv gl:glGetVertexAttribdv
+ALIAS: glGetVertexAttribfv gl:glGetVertexAttribfv
+ALIAS: glGetVertexAttribiv gl:glGetVertexAttribiv
+ALIAS: glGetVertexAttribPointerv gl:glGetVertexAttribPointerv
+ALIAS: glIsProgram gl:glIsProgram
+ALIAS: glIsShader gl:glIsShader
+ALIAS: glLinkProgram gl:glLinkProgram
+ALIAS: glShaderSource gl:glShaderSource
+ALIAS: glUseProgram gl:glUseProgram
+ALIAS: glUniform1f gl:glUniform1f
+ALIAS: glUniform2f gl:glUniform2f
+ALIAS: glUniform3f gl:glUniform3f
+ALIAS: glUniform4f gl:glUniform4f
+ALIAS: glUniform1i gl:glUniform1i
+ALIAS: glUniform2i gl:glUniform2i
+ALIAS: glUniform3i gl:glUniform3i
+ALIAS: glUniform4i gl:glUniform4i
+ALIAS: glUniform1fv gl:glUniform1fv
+ALIAS: glUniform2fv gl:glUniform2fv
+ALIAS: glUniform3fv gl:glUniform3fv
+ALIAS: glUniform4fv gl:glUniform4fv
+ALIAS: glUniform1iv gl:glUniform1iv
+ALIAS: glUniform2iv gl:glUniform2iv
+ALIAS: glUniform3iv gl:glUniform3iv
+ALIAS: glUniform4iv gl:glUniform4iv
+ALIAS: glUniformMatrix2fv gl:glUniformMatrix2fv
+ALIAS: glUniformMatrix3fv gl:glUniformMatrix3fv
+ALIAS: glUniformMatrix4fv gl:glUniformMatrix4fv
+ALIAS: glValidateProgram gl:glValidateProgram
+ALIAS: glVertexAttrib1d gl:glVertexAttrib1d
+ALIAS: glVertexAttrib1dv gl:glVertexAttrib1dv
+ALIAS: glVertexAttrib1f gl:glVertexAttrib1f
+ALIAS: glVertexAttrib1fv gl:glVertexAttrib1fv
+ALIAS: glVertexAttrib1s gl:glVertexAttrib1s
+ALIAS: glVertexAttrib1sv gl:glVertexAttrib1sv
+ALIAS: glVertexAttrib2d gl:glVertexAttrib2d
+ALIAS: glVertexAttrib2dv gl:glVertexAttrib2dv
+ALIAS: glVertexAttrib2f gl:glVertexAttrib2f
+ALIAS: glVertexAttrib2fv gl:glVertexAttrib2fv
+ALIAS: glVertexAttrib2s gl:glVertexAttrib2s
+ALIAS: glVertexAttrib2sv gl:glVertexAttrib2sv
+ALIAS: glVertexAttrib3d gl:glVertexAttrib3d
+ALIAS: glVertexAttrib3dv gl:glVertexAttrib3dv
+ALIAS: glVertexAttrib3f gl:glVertexAttrib3f
+ALIAS: glVertexAttrib3fv gl:glVertexAttrib3fv
+ALIAS: glVertexAttrib3s gl:glVertexAttrib3s
+ALIAS: glVertexAttrib3sv gl:glVertexAttrib3sv
+ALIAS: glVertexAttrib4Nbv gl:glVertexAttrib4Nbv
+ALIAS: glVertexAttrib4Niv gl:glVertexAttrib4Niv
+ALIAS: glVertexAttrib4Nsv gl:glVertexAttrib4Nsv
+ALIAS: glVertexAttrib4Nub gl:glVertexAttrib4Nub
+ALIAS: glVertexAttrib4Nubv gl:glVertexAttrib4Nubv
+ALIAS: glVertexAttrib4Nuiv gl:glVertexAttrib4Nuiv
+ALIAS: glVertexAttrib4Nusv gl:glVertexAttrib4Nusv
+ALIAS: glVertexAttrib4bv gl:glVertexAttrib4bv
+ALIAS: glVertexAttrib4d gl:glVertexAttrib4d
+ALIAS: glVertexAttrib4dv gl:glVertexAttrib4dv
+ALIAS: glVertexAttrib4f gl:glVertexAttrib4f
+ALIAS: glVertexAttrib4fv gl:glVertexAttrib4fv
+ALIAS: glVertexAttrib4iv gl:glVertexAttrib4iv
+ALIAS: glVertexAttrib4s gl:glVertexAttrib4s
+ALIAS: glVertexAttrib4sv gl:glVertexAttrib4sv
+ALIAS: glVertexAttrib4ubv gl:glVertexAttrib4ubv
+ALIAS: glVertexAttrib4uiv gl:glVertexAttrib4uiv
+ALIAS: glVertexAttrib4usv gl:glVertexAttrib4usv
+ALIAS: glVertexAttribPointer gl:glVertexAttribPointer
+ALIAS: glUniformMatrix2x3fv gl:glUniformMatrix2x3fv
+ALIAS: glUniformMatrix3x2fv gl:glUniformMatrix3x2fv
+ALIAS: glUniformMatrix2x4fv gl:glUniformMatrix2x4fv
+ALIAS: glUniformMatrix4x2fv gl:glUniformMatrix4x2fv
+ALIAS: glUniformMatrix3x4fv gl:glUniformMatrix3x4fv
+ALIAS: glUniformMatrix4x3fv gl:glUniformMatrix4x3fv
+ALIAS: glColorMaski gl:glColorMaski
+ALIAS: glGetBooleani_v gl:glGetBooleani_v
+ALIAS: glGetIntegeri_v gl:glGetIntegeri_v
+ALIAS: glEnablei gl:glEnablei
+ALIAS: glDisablei gl:glDisablei
+ALIAS: glIsEnabledi gl:glIsEnabledi
+ALIAS: glBeginTransformFeedback gl:glBeginTransformFeedback
+ALIAS: glEndTransformFeedback gl:glEndTransformFeedback
+ALIAS: glBindBufferRange gl:glBindBufferRange
+ALIAS: glBindBufferBase gl:glBindBufferBase
+ALIAS: glTransformFeedbackVaryings gl:glTransformFeedbackVaryings
+ALIAS: glGetTransformFeedbackVarying gl:glGetTransformFeedbackVarying
+ALIAS: glClampColor gl:glClampColor
+ALIAS: glBeginConditionalRender gl:glBeginConditionalRender
+ALIAS: glEndConditionalRender gl:glEndConditionalRender
+ALIAS: glVertexAttribIPointer gl:glVertexAttribIPointer
+ALIAS: glGetVertexAttribIiv gl:glGetVertexAttribIiv
+ALIAS: glGetVertexAttribIuiv gl:glGetVertexAttribIuiv
+ALIAS: glGetUniformuiv gl:glGetUniformuiv
+ALIAS: glBindFragDataLocation gl:glBindFragDataLocation
+ALIAS: glGetFragDataLocation gl:glGetFragDataLocation
+ALIAS: glUniform1ui gl:glUniform1ui
+ALIAS: glUniform2ui gl:glUniform2ui
+ALIAS: glUniform3ui gl:glUniform3ui
+ALIAS: glUniform4ui gl:glUniform4ui
+ALIAS: glUniform1uiv gl:glUniform1uiv
+ALIAS: glUniform2uiv gl:glUniform2uiv
+ALIAS: glUniform3uiv gl:glUniform3uiv
+ALIAS: glUniform4uiv gl:glUniform4uiv
+ALIAS: glTexParameterIiv gl:glTexParameterIiv
+ALIAS: glTexParameterIuiv gl:glTexParameterIuiv
+ALIAS: glGetTexParameterIiv gl:glGetTexParameterIiv
+ALIAS: glGetTexParameterIuiv gl:glGetTexParameterIuiv
+ALIAS: glClearBufferiv gl:glClearBufferiv
+ALIAS: glClearBufferuiv gl:glClearBufferuiv
+ALIAS: glClearBufferfv gl:glClearBufferfv
+ALIAS: glClearBufferfi gl:glClearBufferfi
+ALIAS: glGetStringi gl:glGetStringi
+ALIAS: glDrawArraysInstanced gl:glDrawArraysInstanced
+ALIAS: glDrawElementsInstanced gl:glDrawElementsInstanced
+ALIAS: glTexBuffer gl:glTexBuffer
+ALIAS: glPrimitiveRestartIndex gl:glPrimitiveRestartIndex
+ALIAS: glIsRenderbuffer gl:glIsRenderbuffer
+ALIAS: glBindRenderbuffer gl:glBindRenderbuffer
+ALIAS: glDeleteRenderbuffers gl:glDeleteRenderbuffers
+ALIAS: glGenRenderbuffers gl:glGenRenderbuffers
+ALIAS: glRenderbufferStorage gl:glRenderbufferStorage
+ALIAS: glGetRenderbufferParameteriv gl:glGetRenderbufferParameteriv
+ALIAS: glIsFramebuffer gl:glIsFramebuffer
+ALIAS: glBindFramebuffer gl:glBindFramebuffer
+ALIAS: glDeleteFramebuffers gl:glDeleteFramebuffers
+ALIAS: glGenFramebuffers gl:glGenFramebuffers
+ALIAS: glCheckFramebufferStatus gl:glCheckFramebufferStatus
+ALIAS: glFramebufferTexture1D gl:glFramebufferTexture1D
+ALIAS: glFramebufferTexture2D gl:glFramebufferTexture2D
+ALIAS: glFramebufferTexture3D gl:glFramebufferTexture3D
+ALIAS: glFramebufferRenderbuffer gl:glFramebufferRenderbuffer
+ALIAS: glGetFramebufferAttachmentParameteriv gl:glGetFramebufferAttachmentParameteriv
+ALIAS: glGenerateMipmap gl:glGenerateMipmap
+ALIAS: glBlitFramebuffer gl:glBlitFramebuffer
+ALIAS: glRenderbufferStorageMultisample gl:glRenderbufferStorageMultisample
+ALIAS: glFramebufferTextureLayer gl:glFramebufferTextureLayer
+ALIAS: glMapBufferRange gl:glMapBufferRange
+ALIAS: glFlushMappedBufferRange gl:glFlushMappedBufferRange
+ALIAS: glBindVertexArray gl:glBindVertexArray
+ALIAS: glDeleteVertexArrays gl:glDeleteVertexArrays
+ALIAS: glGenVertexArrays gl:glGenVertexArrays
+ALIAS: glIsVertexArray gl:glIsVertexArray
+ALIAS: glGetUniformIndices gl:glGetUniformIndices
+ALIAS: glGetActiveUniformsiv gl:glGetActiveUniformsiv
+ALIAS: glGetActiveUniformName gl:glGetActiveUniformName
+ALIAS: glGetUniformBlockIndex gl:glGetUniformBlockIndex
+ALIAS: glGetActiveUniformBlockiv gl:glGetActiveUniformBlockiv
+ALIAS: glGetActiveUniformBlockName gl:glGetActiveUniformBlockName
+ALIAS: glUniformBlockBinding gl:glUniformBlockBinding
+ALIAS: glCopyBufferSubData gl:glCopyBufferSubData
--- /dev/null
+Forward-compatible subset of OpenGL 3.1
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 } }
{ $description "Binds texture " { $snippet "id" } " to texture target " { $snippet "target" } " of texture unit " { $snippet "unit" } ". Equivalent to " { $snippet "unit glActiveTexture target id glBindTexture" } "." } ;
HELP: set-draw-buffers
-{ $values { "buffers" "A sequence of buffer words (e.g. " { $snippet "GL_BACK" } ", " { $snippet "GL_COLOR_ATTACHMENT0_EXT" } ")"} }
+{ $values { "buffers" "A sequence of buffer words (e.g. " { $snippet "GL_BACK" } ", " { $snippet "GL_COLOR_ATTACHMENT0" } ")"} }
{ $description "Wrapper for " { $link glDrawBuffers } ". Sets up the buffers named in the sequence for simultaneous drawing." } ;
HELP: do-attribs
$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 [
[
! Programs
-: <mrt-gl-program> ( shaders frag-data-locations -- program )
+: (gl-program) ( shaders quot: ( gl-program -- ) -- program )
glCreateProgram
[
[ swap [ glAttachShader ] with each ]
- [ swap [ first2 swap glBindFragDataLocationEXT ] with each ] bi-curry bi*
- ]
- [ glLinkProgram ]
- [ ] tri
- gl-error ;
+ [ swap call ] bi-curry bi*
+ ] [ glLinkProgram ] [ ] tri gl-error ; inline
+
+: <mrt-gl-program> ( shaders frag-data-locations -- program )
+ [ [ first2 swap glBindFragDataLocation ] with each ] curry (gl-program) ;
: <gl-program> ( shaders -- program )
- glCreateProgram
- [ swap [ glAttachShader ] with each ]
- [ glLinkProgram ]
- [ ] tri
- gl-error ;
+ [ drop ] (gl-program) ;
: (gl-program?) ( object -- ? )
dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test opengl.textures opengl.textures.private
-images kernel namespaces accessors sequences ;
+USING: tools.test opengl.gl opengl.textures opengl.textures.private
+images kernel namespaces accessors sequences literals ;
IN: opengl.textures.tests
[
{ { 10 30 } { 30 300 } }
}
[ [ image new swap >>dim ] map ] map image-locs
-] unit-test
\ No newline at end of file
+] unit-test
+
+${ GL_RGBA8 GL_RGBA GL_UNSIGNED_BYTE }
+[ RGBA ubyte-components (image-format) ] unit-test
+
+${ GL_RGBA8 GL_BGRA GL_UNSIGNED_BYTE }
+[ BGRA ubyte-components (image-format) ] unit-test
+
+${ GL_RGBA8 GL_BGRA GL_UNSIGNED_INT_8_8_8_8_REV }
+[ ARGB ubyte-components (image-format) ] unit-test
+
+${ GL_RGBA32F GL_RGBA GL_FLOAT }
+[ RGBA float-components (image-format) ] unit-test
+
+${ GL_RGBA32UI GL_BGRA_INTEGER GL_UNSIGNED_INT }
+[ BGRA uint-integer-components (image-format) ] unit-test
+
+${ GL_RGB9_E5 GL_RGB GL_UNSIGNED_INT_5_9_9_9_REV }
+[ BGR u-9-9-9-e5-components (image-format) ] unit-test
+
+${ GL_R11F_G11F_B10F GL_RGB GL_UNSIGNED_INT_10F_11F_11F_REV }
+[ BGR float-11-11-10-components (image-format) ] unit-test
opengl opengl.gl opengl.capabilities combinators images
images.tesselation grouping specialized-arrays.float sequences math
math.vectors math.matrices generalizations fry arrays namespaces
-system ;
+system locals literals ;
IN: opengl.textures
SYMBOL: non-power-of-2-textures?
: delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
-GENERIC: component-order>format ( component-order -- format type )
+ERROR: unsupported-component-order component-order component-type ;
+
+CONSTANT: image-internal-formats H{
+ { { A ubyte-components } $ GL_ALPHA8 }
+ { { A ushort-components } $ GL_ALPHA16 }
+ { { A half-components } $ GL_ALPHA16F_ARB }
+ { { A float-components } $ GL_ALPHA32F_ARB }
+ { { A byte-integer-components } $ GL_ALPHA8I_EXT }
+ { { A ubyte-integer-components } $ GL_ALPHA8UI_EXT }
+ { { A short-integer-components } $ GL_ALPHA16I_EXT }
+ { { A ushort-integer-components } $ GL_ALPHA16UI_EXT }
+ { { A int-integer-components } $ GL_ALPHA32I_EXT }
+ { { A uint-integer-components } $ GL_ALPHA32UI_EXT }
+
+ { { L ubyte-components } $ GL_LUMINANCE8 }
+ { { L ushort-components } $ GL_LUMINANCE16 }
+ { { L half-components } $ GL_LUMINANCE16F_ARB }
+ { { L float-components } $ GL_LUMINANCE32F_ARB }
+ { { L byte-integer-components } $ GL_LUMINANCE8I_EXT }
+ { { L ubyte-integer-components } $ GL_LUMINANCE8UI_EXT }
+ { { L short-integer-components } $ GL_LUMINANCE16I_EXT }
+ { { L ushort-integer-components } $ GL_LUMINANCE16UI_EXT }
+ { { L int-integer-components } $ GL_LUMINANCE32I_EXT }
+ { { L uint-integer-components } $ GL_LUMINANCE32UI_EXT }
+
+ { { R ubyte-components } $ GL_R8 }
+ { { R ushort-components } $ GL_R16 }
+ { { R half-components } $ GL_R16F }
+ { { R float-components } $ GL_R32F }
+ { { R byte-integer-components } $ GL_R8I }
+ { { R ubyte-integer-components } $ GL_R8UI }
+ { { R short-integer-components } $ GL_R16I }
+ { { R ushort-integer-components } $ GL_R16UI }
+ { { R int-integer-components } $ GL_R32I }
+ { { R uint-integer-components } $ GL_R32UI }
+
+ { { INTENSITY ubyte-components } $ GL_INTENSITY8 }
+ { { INTENSITY ushort-components } $ GL_INTENSITY16 }
+ { { INTENSITY half-components } $ GL_INTENSITY16F_ARB }
+ { { INTENSITY float-components } $ GL_INTENSITY32F_ARB }
+ { { INTENSITY byte-integer-components } $ GL_INTENSITY8I_EXT }
+ { { INTENSITY ubyte-integer-components } $ GL_INTENSITY8UI_EXT }
+ { { INTENSITY short-integer-components } $ GL_INTENSITY16I_EXT }
+ { { INTENSITY ushort-integer-components } $ GL_INTENSITY16UI_EXT }
+ { { INTENSITY int-integer-components } $ GL_INTENSITY32I_EXT }
+ { { INTENSITY uint-integer-components } $ GL_INTENSITY32UI_EXT }
+
+ { { DEPTH ushort-components } $ GL_DEPTH_COMPONENT16 }
+ { { DEPTH u-24-components } $ GL_DEPTH_COMPONENT24 }
+ { { DEPTH uint-components } $ GL_DEPTH_COMPONENT32 }
+ { { DEPTH float-components } $ GL_DEPTH_COMPONENT32F }
+
+ { { LA ubyte-components } $ GL_LUMINANCE8_ALPHA8 }
+ { { LA ushort-components } $ GL_LUMINANCE16_ALPHA16 }
+ { { LA half-components } $ GL_LUMINANCE_ALPHA16F_ARB }
+ { { LA float-components } $ GL_LUMINANCE_ALPHA32F_ARB }
+ { { LA byte-integer-components } $ GL_LUMINANCE_ALPHA8I_EXT }
+ { { LA ubyte-integer-components } $ GL_LUMINANCE_ALPHA8UI_EXT }
+ { { LA short-integer-components } $ GL_LUMINANCE_ALPHA16I_EXT }
+ { { LA ushort-integer-components } $ GL_LUMINANCE_ALPHA16UI_EXT }
+ { { LA int-integer-components } $ GL_LUMINANCE_ALPHA32I_EXT }
+ { { LA uint-integer-components } $ GL_LUMINANCE_ALPHA32UI_EXT }
+
+ { { RG ubyte-components } $ GL_RG8 }
+ { { RG ushort-components } $ GL_RG16 }
+ { { RG half-components } $ GL_RG16F }
+ { { RG float-components } $ GL_RG32F }
+ { { RG byte-integer-components } $ GL_RG8I }
+ { { RG ubyte-integer-components } $ GL_RG8UI }
+ { { RG short-integer-components } $ GL_RG16I }
+ { { RG ushort-integer-components } $ GL_RG16UI }
+ { { RG int-integer-components } $ GL_RG32I }
+ { { RG uint-integer-components } $ GL_RG32UI }
+
+ { { DEPTH-STENCIL u-24-8-components } $ GL_DEPTH24_STENCIL8 }
+ { { DEPTH-STENCIL float-32-u-8-components } $ GL_DEPTH32F_STENCIL8 }
+
+ { { RGB ubyte-components } $ GL_RGB8 }
+ { { RGB ushort-components } $ GL_RGB16 }
+ { { RGB half-components } $ GL_RGB16F }
+ { { RGB float-components } $ GL_RGB32F }
+ { { RGB byte-integer-components } $ GL_RGB8I }
+ { { RGB ubyte-integer-components } $ GL_RGB8UI }
+ { { RGB byte-integer-components } $ GL_RGB8I }
+ { { RGB ubyte-integer-components } $ GL_RGB8UI }
+ { { RGB short-integer-components } $ GL_RGB16I }
+ { { RGB ushort-integer-components } $ GL_RGB16UI }
+ { { RGB int-integer-components } $ GL_RGB32I }
+ { { RGB uint-integer-components } $ GL_RGB32UI }
+ { { RGB u-5-6-5-components } $ GL_RGB5 }
+ { { RGB u-9-9-9-e5-components } $ GL_RGB9_E5 }
+ { { RGB float-11-11-10-components } $ GL_R11F_G11F_B10F }
+
+ { { RGBA ubyte-components } $ GL_RGBA8 }
+ { { RGBA ushort-components } $ GL_RGBA16 }
+ { { RGBA half-components } $ GL_RGBA16F }
+ { { RGBA float-components } $ GL_RGBA32F }
+ { { RGBA byte-integer-components } $ GL_RGBA8I }
+ { { RGBA ubyte-integer-components } $ GL_RGBA8UI }
+ { { RGBA byte-integer-components } $ GL_RGBA8I }
+ { { RGBA ubyte-integer-components } $ GL_RGBA8UI }
+ { { RGBA short-integer-components } $ GL_RGBA16I }
+ { { RGBA ushort-integer-components } $ GL_RGBA16UI }
+ { { RGBA int-integer-components } $ GL_RGBA32I }
+ { { RGBA uint-integer-components } $ GL_RGBA32UI }
+ { { RGBA u-5-5-5-1-components } $ GL_RGB5_A1 }
+ { { RGBA u-10-10-10-2-components } $ GL_RGB10_A2 }
+}
+
+GENERIC: fix-internal-component-order ( order -- order' )
+
+M: object fix-internal-component-order ;
+M: BGR fix-internal-component-order drop RGB ;
+M: BGRA fix-internal-component-order drop RGBA ;
+M: ARGB fix-internal-component-order drop RGBA ;
+M: ABGR fix-internal-component-order drop RGBA ;
+M: RGBX fix-internal-component-order drop RGBA ;
+M: BGRX fix-internal-component-order drop RGBA ;
+M: XRGB fix-internal-component-order drop RGBA ;
+M: XBGR fix-internal-component-order drop RGBA ;
+
+: image-internal-format ( component-order component-type -- internal-format )
+ 2dup
+ [ fix-internal-component-order ] dip 2array image-internal-formats at
+ [ 2nip ] [ unsupported-component-order ] if* ;
+
+: reversed-type? ( component-type -- ? )
+ { u-9-9-9-e5-components float-11-11-10-components } member? ;
+
+: (component-order>format) ( component-order component-type -- gl-format )
+ dup unnormalized-integer-components? [
+ swap {
+ { A [ drop GL_ALPHA_INTEGER_EXT ] }
+ { L [ drop GL_LUMINANCE_INTEGER_EXT ] }
+ { R [ drop GL_RED_INTEGER ] }
+ { LA [ drop GL_LUMINANCE_ALPHA_INTEGER_EXT ] }
+ { RG [ drop GL_RG_INTEGER ] }
+ { BGR [ drop GL_BGR_INTEGER ] }
+ { RGB [ drop GL_RGB_INTEGER ] }
+ { BGRA [ drop GL_BGRA_INTEGER ] }
+ { RGBA [ drop GL_RGBA_INTEGER ] }
+ { BGRX [ drop GL_BGRA_INTEGER ] }
+ { RGBX [ drop GL_RGBA_INTEGER ] }
+ [ swap unsupported-component-order ]
+ } case
+ ] [
+ swap {
+ { A [ drop GL_ALPHA ] }
+ { L [ drop GL_LUMINANCE ] }
+ { R [ drop GL_RED ] }
+ { LA [ drop GL_LUMINANCE_ALPHA ] }
+ { RG [ drop GL_RG ] }
+ { BGR [ reversed-type? GL_RGB GL_BGR ? ] }
+ { RGB [ reversed-type? GL_BGR GL_RGB ? ] }
+ { BGRA [ drop GL_BGRA ] }
+ { RGBA [ drop GL_RGBA ] }
+ { ARGB [ drop GL_BGRA ] }
+ { ABGR [ drop GL_RGBA ] }
+ { BGRX [ drop GL_BGRA ] }
+ { RGBX [ drop GL_RGBA ] }
+ { XRGB [ drop GL_BGRA ] }
+ { XBGR [ drop GL_RGBA ] }
+ { INTENSITY [ drop GL_INTENSITY ] }
+ { DEPTH [ drop GL_DEPTH_COMPONENT ] }
+ { DEPTH-STENCIL [ drop GL_DEPTH_STENCIL ] }
+ [ swap unsupported-component-order ]
+ } case
+ ] if ;
+
+GENERIC: (component-type>type) ( component-order component-type -- gl-type )
+
+M: object (component-type>type) unsupported-component-order ;
+
+: four-channel-alpha-first? ( component-order component-type -- ? )
+ over component-count 4 =
+ [ drop alpha-channel-precedes-colors? ]
+ [ unsupported-component-order ] if ;
+
+: not-alpha-first ( component-order component-type -- )
+ over alpha-channel-precedes-colors?
+ [ unsupported-component-order ]
+ [ 2drop ] if ;
+
+M: ubyte-components (component-type>type)
+ drop alpha-channel-precedes-colors?
+ [ GL_UNSIGNED_INT_8_8_8_8_REV ]
+ [ GL_UNSIGNED_BYTE ] if ;
+
+M: ushort-components (component-type>type) not-alpha-first GL_UNSIGNED_SHORT ;
+M: uint-components (component-type>type) not-alpha-first GL_UNSIGNED_INT ;
+M: half-components (component-type>type) not-alpha-first GL_HALF_FLOAT ;
+M: float-components (component-type>type) not-alpha-first GL_FLOAT ;
+M: byte-integer-components (component-type>type) not-alpha-first GL_BYTE ;
+M: ubyte-integer-components (component-type>type) not-alpha-first GL_UNSIGNED_BYTE ;
+M: short-integer-components (component-type>type) not-alpha-first GL_SHORT ;
+M: ushort-integer-components (component-type>type) not-alpha-first GL_UNSIGNED_SHORT ;
+M: int-integer-components (component-type>type) not-alpha-first GL_INT ;
+M: uint-integer-components (component-type>type) not-alpha-first GL_UNSIGNED_INT ;
+
+M: u-5-5-5-1-components (component-type>type)
+ four-channel-alpha-first?
+ [ GL_UNSIGNED_SHORT_1_5_5_5_REV ]
+ [ GL_UNSIGNED_SHORT_5_5_5_1 ] if ;
+
+M: u-5-6-5-components (component-type>type) 2drop GL_UNSIGNED_SHORT_5_6_5 ;
-M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ;
-M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ;
-M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
-M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
-M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
-M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
-M: LA component-order>format drop GL_LUMINANCE_ALPHA GL_UNSIGNED_BYTE ;
-M: L component-order>format drop GL_LUMINANCE GL_UNSIGNED_BYTE ;
+M: u-10-10-10-2-components (component-type>type)
+ four-channel-alpha-first?
+ [ GL_UNSIGNED_INT_2_10_10_10_REV ]
+ [ GL_UNSIGNED_INT_10_10_10_2 ] if ;
+
+M: u-24-components (component-type>type)
+ over DEPTH =
+ [ 2drop GL_UNSIGNED_INT ] [ unsupported-component-order ] if ;
+
+M: u-24-8-components (component-type>type)
+ over DEPTH-STENCIL =
+ [ 2drop GL_UNSIGNED_INT_24_8 ] [ unsupported-component-order ] if ;
+
+M: u-9-9-9-e5-components (component-type>type)
+ over BGR =
+ [ 2drop GL_UNSIGNED_INT_5_9_9_9_REV ] [ unsupported-component-order ] if ;
+
+M: float-11-11-10-components (component-type>type)
+ over BGR =
+ [ 2drop GL_UNSIGNED_INT_10F_11F_11F_REV ] [ unsupported-component-order ] if ;
+
+: image-data-format ( component-order component-type -- gl-format gl-type )
+ [ (component-order>format) ] [ (component-type>type) ] 2bi ;
SLOT: display-list
DEFER: make-texture
+: (image-format) ( component-order component-type -- internal-format format type )
+ [ image-internal-format ] [ image-data-format ] 2bi ;
+
+: image-format ( image -- internal-format format type )
+ [ component-order>> ] [ component-type>> ] bi (image-format) ;
+
<PRIVATE
TUPLE: single-texture image dim loc texture-coords texture display-list disposed ;
[ dup 1 = [ next-power-of-2 ] unless ] map
] unless ;
-: tex-image ( image bitmap -- )
- [
- [ GL_TEXTURE_2D 0 GL_RGBA ] dip
- [ dim>> adjust-texture-dim first2 0 ]
- [ component-order>> component-order>format ] bi
- ] dip
- glTexImage2D ;
+:: tex-image ( image bitmap -- )
+ image image-format :> type :> format :> internal-format
+ GL_TEXTURE_2D 0 internal-format
+ image dim>> adjust-texture-dim first2 0
+ format type bitmap glTexImage2D ;
: tex-sub-image ( image -- )
[ GL_TEXTURE_2D 0 0 0 ] dip
[ dim>> first2 ]
- [ component-order>> component-order>format ]
+ [ image-format [ drop ] 2dip ]
[ bitmap>> ] tri
glTexSubImage2D ;
[ "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 } "." } ;
HELP: word-timing.
{ $description "Prints the word timing table." } ;
+
+HELP: cannot-annotate-twice
+{ $error-description "Thrown when attempting to annotate a word that's already been annotated. If a word already has an annotation such as a watch or a breakpoint, you must first " { $link reset } " the word before adding another annotation." } ;
\ No newline at end of file
[ ] [ 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 ;
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tr arrays sequences io words generic system combinators
-vocabs.loader kernel ;
+USING: alien alien.c-types arrays byte-arrays combinators
+destructors generic io kernel libc math sequences system tr
+vocabs.loader words ;
IN: tools.disassembler
GENERIC: disassemble ( obj -- )
TR: tabs>spaces "\t" "\s" ;
+M: byte-array disassemble
+ [
+ [ malloc-byte-array &free alien-address dup ]
+ [ length + ] bi
+ 2array disassemble
+ ] with-destructors ;
+
M: pair disassemble first2 disassemble* [ tabs>spaces print ] each ;
M: word disassemble word-xt 2array disassemble ;
{ "str" string }
{ "hash" hashtable }
{ "hashtable" hashtable }
- { "?" "a boolean" }
+ { "?" boolean }
{ "ch" "a character" }
{ "word" word }
{ "array" array }
[ 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 -- )
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays assocs cocoa kernel math
-cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
-cocoa.application cocoa.pasteboard cocoa.types cocoa.windows sequences
-ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.gestures core-foundation.strings core-graphics core-graphics.types
-threads combinators math.rectangles ;
+USING: accessors alien alien.c-types alien.strings arrays assocs
+cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes
+cocoa.views cocoa.application cocoa.pasteboard cocoa.types
+cocoa.windows sequences io.encodings.ascii ui ui.private ui.gadgets
+ui.gadgets.private ui.gadgets.worlds ui.gestures
+core-foundation.strings core-graphics core-graphics.types threads
+combinators math.rectangles ;
IN: ui.backend.cocoa.views
: send-mouse-moved ( view event -- )
[ drop dim>> first2 ]
2bi <CGRect> ;
+CONSTANT: selector>action H{
+ { "undo:" undo-action }
+ { "redo:" redo-action }
+ { "cut:" cut-action }
+ { "copy:" copy-action }
+ { "paste:" paste-action }
+ { "delete:" delete-action }
+ { "selectAll:" select-all-action }
+ { "newDocument:" new-action }
+ { "openDocument:" open-action }
+ { "saveDocument:" save-action }
+ { "saveDocumentAs:" save-as-action }
+ { "revertDocumentToSaved:" revert-action }
+}
+
+: validate-action ( world selector -- ? validated? )
+ selector>action at
+ [ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ;
+
CLASS: {
{ +superclass+ "NSOpenGLView" }
{ +name+ "FactorView" }
[ nip send-key-up-event ]
}
+{ "validateUserInterfaceItem:" "char" { "id" "SEL" "id" }
+ [
+ nip -> action
+ 2dup [ window ] [ ascii alien>string ] bi* validate-action
+ [ [ 2drop ] dip >c-bool ] [ SUPER-> validateUserInterfaceItem: ] if
+ ]
+}
+
{ "undo:" "id" { "id" "SEL" "id" }
[ nip undo-action send-action$ ]
}
[ nip select-all-action send-action$ ]
}
+{ "newDocument:" "id" { "id" "SEL" "id" }
+ [ nip new-action send-action$ ]
+}
+
+{ "openDocument:" "id" { "id" "SEL" "id" }
+ [ nip open-action send-action$ ]
+}
+
+{ "saveDocument:" "id" { "id" "SEL" "id" }
+ [ nip save-action send-action$ ]
+}
+
+{ "saveDocumentAs:" "id" { "id" "SEL" "id" }
+ [ nip save-as-action send-action$ ]
+}
+
+{ "revertDocumentToSaved:" "id" { "id" "SEL" "id" }
+ [ nip revert-action send-action$ ]
+}
+
! Multi-touch gestures: this is undocumented.
! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
{ "magnifyWithEvent:" "void" { "id" "SEL" "id" }
] [ 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-value ] if ;
+ dup [ mouse-row ] keep valid-line? [
+ dup row-action? [ row-action ] [ update-selected-value ] 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
"Outputs " { $link f } " if the gesture was handled, and " { $link t } " if the gesture should be passed on to the gadget's parent."
$nl
"The default implementation looks at the " { $snippet "\"gestures\"" } " word property of each superclass of the gadget's class." }
-{ $notes "Methods should be defined on this word if you desire to handle an arbitrary set of gestures. To define handlers for a fixed set, it is easier to use " { $link set-gestures } "." } ;
+{ $notes "Methods should be defined on this word if you desire to handle an arbitrary set of gestures. To define handlers for a fixed set, it is easier to use " { $link set-gestures } ". If you define a method on " { $snippet "handle-gesture" } ", you should also override " { $link handles-gesture? } "." } ;
-{ propagate-gesture handle-gesture set-gestures } related-words
+HELP: handles-gesture?
+{ $values { "gesture" "a gesture" } { "gadget" "the receiver of the gesture" } { "?" "a boolean" } }
+{ $contract "Returns a true value if " { $snippet "gadget" } " would handle " { $snippet "gesture" } " in its " { $link handle-gesture } " method."
+$nl
+"The default implementation looks at the " { $snippet "\"gestures\"" } " word property of each superclass of the gadget's class and returns true if a handler is present for " { $snippet "gesture" } "." }
+{ $notes "This word is used in Factor's MacOS X UI to validate menu items." } ;
+
+HELP: parents-handle-gesture?
+{ $values { "gesture" "a gesture" } { "gadget" "the receiver of the gesture" } { "?" "a boolean" } }
+{ $contract "Returns a true value if " { $snippet "gadget" } " or any of its ancestors would handle " { $snippet "gesture" } " in its " { $link handle-gesture } " method." } ;
+
+{ propagate-gesture handle-gesture handles-gesture? set-gestures } related-words
HELP: propagate-gesture
{ $values { "gesture" "a gesture" } { "gadget" gadget } }
{ $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." }
{ $examples { $code "select-all-action" } } ;
+HELP: new-action
+{ $class-description "Gesture sent when the " { $emphasis "new" } " standard window system action is invoked." }
+{ $examples { $code "new-action" } } ;
+
+HELP: open-action
+{ $class-description "Gesture sent when the " { $emphasis "open" } " standard window system action is invoked." }
+{ $examples { $code "open-action" } } ;
+
+HELP: save-action
+{ $class-description "Gesture sent when the " { $emphasis "save" } " standard window system action is invoked." }
+{ $examples { $code "save-action" } } ;
+
+HELP: save-as-action
+{ $class-description "Gesture sent when the " { $emphasis "save as" } " standard window system action is invoked." }
+{ $examples { $code "save-as-action" } } ;
+
+HELP: revert-action
+{ $class-description "Gesture sent when the " { $emphasis "revert" } " standard window system action is invoked." }
+{ $examples { $code "revert-action" } } ;
+
+HELP: close-action
+{ $class-description "Gesture sent when the " { $emphasis "close" } " standard window system action is invoked." }
+{ $examples { $code "close-action" } } ;
+
HELP: C+
{ $description "Control key modifier." } ;
{ $subsection zoom-out-action } ;
ARTICLE: "action-gestures" "Action gestures"
-"Action gestures exist to keep keyboard shortcuts for common clipboard operations consistent."
+"Action gestures exist to keep keyboard shortcuts for common application operations consistent."
+{ $subsection undo-action }
+{ $subsection redo-action }
{ $subsection cut-action }
{ $subsection copy-action }
{ $subsection paste-action }
{ $subsection delete-action }
{ $subsection select-all-action }
+{ $subsection new-action }
+{ $subsection open-action }
+{ $subsection save-action }
+{ $subsection save-as-action }
+{ $subsection revert-action }
+{ $subsection close-action }
"The following keyboard gestures, if not handled directly, send action gestures:"
{ $table
{ { $strong "Keyboard gesture" } { $strong "Action gesture" } }
{ { $snippet "T{ key-down f { C+ } \"z\" }" } { $snippet "undo-action" } }
- { { $snippet "T{ key-down f { C+ } \"Z\" }" } { $snippet "redo-action" } }
+ { { $snippet "T{ key-down f { C+ } \"y\" }" } { $snippet "redo-action" } }
{ { $snippet "T{ key-down f { C+ } \"x\" }" } { $snippet "cut-action" } }
{ { $snippet "T{ key-down f { C+ } \"c\" }" } { $snippet "copy-action" } }
{ { $snippet "T{ key-down f { C+ } \"v\" }" } { $snippet "paste-action" } }
{ { $snippet "T{ key-down f { C+ } \"a\" }" } { $snippet "select-all-action" } }
+ { { $snippet "T{ key-down f { C+ } \"n\" }" } { $snippet "new-action" } }
+ { { $snippet "T{ key-down f { C+ } \"o\" }" } { $snippet "open-action" } }
+ { { $snippet "T{ key-down f { C+ } \"s\" }" } { $snippet "save-action" } }
+ { { $snippet "T{ key-down f { C+ } \"S\" }" } { $snippet "save-as-action" } }
+ { { $snippet "T{ key-down f { C+ } \"w\" }" } { $snippet "close-action" } }
}
"Action gestures should be used in place of the above keyboard gestures if possible. For example, on Mac OS X, the standard " { $strong "Edit" } " menu items send action gestures." ;
combinators.short-circuit ;
IN: ui.gestures
+: get-gesture-handler ( gesture gadget -- quot )
+ class superclasses [ "gestures" word-prop ] map assoc-stack ;
+
GENERIC: handle-gesture ( gesture gadget -- ? )
M: object handle-gesture
[ nip ]
- [ class superclasses [ "gestures" word-prop ] map assoc-stack ] 2bi
+ [ get-gesture-handler ] 2bi
dup [ call( gadget -- ) f ] [ 2drop t ] if ;
+GENERIC: handles-gesture? ( gesture gadget -- ? )
+
+M: object handles-gesture? ( gesture gadget -- ? )
+ get-gesture-handler >boolean ;
+
+: parents-handle-gesture? ( gesture gadget -- ? )
+ [ handles-gesture? not ] with each-parent not ;
+
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
: gesture-queue ( -- deque ) \ gesture-queue get ;
cut-action copy-action paste-action
delete-action select-all-action
left-action right-action up-action down-action
-zoom-in-action zoom-out-action ;
+zoom-in-action zoom-out-action
+new-action open-action save-action save-as-action
+revert-action close-action ;
UNION: action
undo-action redo-action
cut-action copy-action paste-action
delete-action select-all-action
left-action right-action up-action down-action
-zoom-in-action zoom-out-action ;
+zoom-in-action zoom-out-action
+new-action open-action save-action save-as-action
+revert-action close-action ;
CONSTANT: action-gestures
{
{ "z" undo-action }
- { "Z" redo-action }
+ { "y" redo-action }
{ "x" cut-action }
{ "c" copy-action }
{ "v" paste-action }
{ "a" select-all-action }
+ { "n" new-action }
+ { "o" open-action }
+ { "s" save-action }
+ { "S" save-as-action }
+ { "w" close-action }
}
! Modifiers
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 }
HELP: beep
{ $description "Plays the system beep sound." } ;
+HELP: topmost-window
+{ $values { "world" world } }
+{ $description "Returns the " { $link world } " representing the currently focused window." } ;
+
ARTICLE: "ui-glossary" "UI glossary"
{ $table
{ "color" { "an instance of " { $link color } } }
: 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*
: raise-window ( gadget -- )
find-world raise-window* ;
+: topmost-window ( -- world )
+ windows get last second ;
+
HOOK: close-window ui-backend ( gadget -- )
M: object close-window
"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: alien.syntax ;
+USING: alien.syntax alien.c-types ;
IN: unix.types
TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t
+
+ALIAS: <time_t> <int>
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
IN: unix.types
TYPEDEF: ulonglong __uquad_type
TYPEDEF: ulonglong __fsfilcnt64_t
TYPEDEF: ulonglong ino64_t
TYPEDEF: ulonglong off64_t
+
+ALIAS: <time_t> <long>
\ No newline at end of file
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
IN: unix.types
! Darwin 9.1.0
TYPEDEF: long ssize_t
TYPEDEF: __int32_t pid_t
TYPEDEF: long time_t
+
+ALIAS: <time_t> <long>
\ No newline at end of file
-USING: alien.syntax combinators layouts vocabs.loader ;
+USING: alien.syntax alien.c-types combinators layouts vocabs.loader ;
IN: unix.types
! NetBSD 4.0
TYPEDEF: int pid_t
TYPEDEF: int time_t
+ALIAS: <time_t> <int>
+
cell-bits {
{ 32 [ "unix.types.netbsd.32" require ] }
{ 64 [ "unix.types.netbsd.64" require ] }
-USING: alien.syntax ;
+USING: alien.syntax alien.c-types ;
IN: unix.types
! OpenBSD 4.2
TYPEDEF: long ssize_t
TYPEDEF: int pid_t
TYPEDEF: int time_t
+
+ALIAS: <time_t> <int>
\ No newline at end of file
"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
swap >>dim
swap >>bitmap
BGRX >>component-order
+ ubyte-components >>component-type
t >>upside-down? ;
: with-memory-dc ( quot: ( hDC -- ) -- )
:: make-bitmap-image ( dim dc quot -- image )
dim dc make-bitmap [ &DeleteObject drop ] dip
quot dip
- dim bitmap>image ; inline
\ No newline at end of file
+ dim bitmap>image ; inline
[ "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 ;
{ "XImage-funcs" "f" } ;
X-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
-X-FUNCTION: int XDestroyImage ( XImage *ximage ) ;
+X-FUNCTION: int XDestroyImage ( XImage* ximage ) ;
: XImage-size ( ximage -- size )
[ XImage-height ] [ XImage-bytes_per_line ] bi * ;
[ "( 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
\r
PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;\r
\r
-: (class<=) ( first second -- -1/0/1 )\r
+: (class<=) ( first second -- ? )\r
2dup eq? [ 2drop t ] [\r
2dup superclass<= [ 2drop t ] [\r
[ normalize-class ] bi@ {\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
: h>b/b ( h -- b1 b2 )
[ mask-byte ]
[ -8 shift mask-byte ] bi ;
+
+: signed-le> ( bytes -- x )
+ [ le> ] [ length 8 * 1 - 2^ 1 - ] bi
+ 2dup > [ bitnot bitor ] [ drop ] if ;
+
+: signed-be> ( bytes -- x )
+ <reversed> signed-le> ;
USING: help.markup help.syntax math math.private ;
IN: math.floats
-ARTICLE: "floats" "Floats"
-{ $subsection float }
-"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximation" } ". While rationals can grow to any required precision, floating point numbers are fixed-width, and manipulating them is usually faster than manipulating ratios or bignums (but slower than manipulating fixnums). Floating point numbers are often used to represent irrational numbers, which have no exact representation as a ratio of two integers."
-$nl
-"Introducing a floating point number in a computation forces the result to be expressed in floating point."
-{ $example "5/4 1/2 + ." "1+3/4" }
-{ $example "5/4 0.5 + ." "1.75" }
-"Integers and rationals can be converted to floats:"
-{ $subsection >float }
-"Two real numbers can be divided yielding a float result:"
-{ $subsection /f }
-"Floating point numbers are represented internally in IEEE 754 double-precision format. This internal representation can be accessed for advanced operations and input/output purposes."
-{ $subsection float>bits }
-{ $subsection double>bits }
-{ $subsection bits>float }
-{ $subsection bits>double }
-{ $see-also "syntax-floats" } ;
-
-ABOUT: "floats"
-
HELP: float
{ $class-description "The class of double-precision floating point numbers." } ;
{ $description "Converts a real to a float. This is the identity on floats, and performs a floating point division on rationals." } ;
HELP: bits>double ( n -- x )
-{ $values { "n" "a 64-bit integer representing an 754 double-precision float" } { "x" float } }
+{ $values { "n" "a 64-bit integer representing an IEEE 754 double-precision float" } { "x" float } }
{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
{ bits>double bits>float double>bits float>bits } related-words
HELP: bits>float ( n -- x )
-{ $values { "n" "a 32-bit integer representing an 754 single-precision float" } { "x" float } }
+{ $values { "n" "a 32-bit integer representing an IEEE 754 single-precision float" } { "x" float } }
{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
HELP: double>bits ( x -- n )
-{ $values { "x" float } { "n" "a 64-bit integer representing an 754 double-precision float" } }
+{ $values { "x" float } { "n" "a 64-bit integer representing an IEEE 754 double-precision float" } }
{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
HELP: float>bits ( x -- n )
-{ $values { "x" float } { "n" "a 32-bit integer representing an 754 single-precision float" } }
+{ $values { "x" float } { "n" "a 32-bit integer representing an IEEE 754 single-precision float" } }
{ $description "Creates a " { $link float } " object from a binary representation. This word is usually used to reconstruct floats read from streams." } ;
! Unsafe primitives
{ $values { "x" float } { "y" float } { "?" "a boolean" } }
{ $description "Primitive version of " { $link >= } "." }
{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link >= } " instead." } ;
+
+ARTICLE: "floats" "Floats"
+{ $subsection float }
+"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums."
+$nl
+"Introducing a floating point number in a computation forces the result to be expressed in floating point."
+{ $example "5/4 1/2 + ." "1+3/4" }
+{ $example "5/4 0.5 + ." "1.75" }
+"Integers and rationals can be converted to floats:"
+{ $subsection >float }
+"Two real numbers can be divided yielding a float result:"
+{ $subsection /f }
+"Floating point numbers are represented internally in IEEE 754 double-precision format. This internal representation can be accessed for advanced operations and input/output purposes."
+{ $subsection float>bits }
+{ $subsection double>bits }
+{ $subsection bits>float }
+{ $subsection bits>double }
+"Constructing floating point NaNs:"
+{ $subsection <fp-nan> }
+"Floating point numbers are discrete:"
+{ $subsection prev-float }
+{ $subsection next-float }
+"Introspection on floating point numbers:"
+{ $subsection fp-special? }
+{ $subsection fp-nan? }
+{ $subsection fp-qnan? }
+{ $subsection fp-snan? }
+{ $subsection fp-infinity? }
+{ $subsection fp-nan-payload }
+"Comparing two floating point numbers:"
+{ $subsection fp-bitwise= }
+{ $see-also "syntax-floats" } ;
+
+ABOUT: "floats"
} ;
HELP: <
-{ $values { "x" real } { "y" real } { "?" "a boolean" } }
+{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } ;
HELP: <=
-{ $values { "x" real } { "y" real } { "?" "a boolean" } }
+{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } ;
HELP: >
-{ $values { "x" real } { "y" real } { "?" "a boolean" } }
+{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } ;
HELP: >=
-{ $values { "x" real } { "y" real } { "?" "a boolean" } }
+{ $values { "x" real } { "y" real } { "?" boolean } }
{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
{ $example "USING: io math ;" "3 [ \"Hi\" print ] times" "Hi\nHi\nHi" }
} ;
+HELP: fp-bitwise=
+{ $values
+ { "x" float } { "y" float }
+ { "?" boolean }
+}
+{ $description "Compares two floating point numbers for bit equality." } ;
+
HELP: fp-special?
{ $values { "x" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is an IEEE special value (Not-a-Number or Infinity). While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
HELP: next-float
{ $values { "m" float } { "n" float } }
-{ $description "Returns the least representable " { $link float } " value greater than " { $snippet "m" } "." } ;
+{ $description "Returns the least representable " { $link float } " value greater than " { $snippet "m" } ", or in the case of " { $snippet "-0.0" } ", returns " { $snippet "+0.0" } "." } ;
HELP: prev-float
{ $values { "m" float } { "n" float } }
-{ $description "Returns the greatest representable " { $link float } " value less than " { $snippet "m" } "." } ;
+{ $description "Returns the greatest representable " { $link float } " value less than " { $snippet "m" } ", or in the case of " { $snippet "+0.0" } ", returns " { $snippet "-0.0" } "." } ;
{ next-float prev-float } related-words
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 << >>
} ;
HELP: slice
-{ $class-description "A virtual sequence which presents a subrange of the elements of an underlying sequence. New instances can be created by calling " { $link <slice> } "."
+{ $class-description "A virtual sequence which presents a subrange of the elements of an underlying sequence. New instances can be created by calling " { $link <slice> } ". Convenience words are also provided for creating slices where one endpoint is the start or end of the sequence; see " { $link "sequences-slices" } " for a list."
$nl
"Slices are mutable if the underlying sequence is mutable, and mutating a slice changes the underlying sequence. However, slices cannot be resized after creation." } ;
{ "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 }"
}
}
} ;
+HELP: assert-sequence=
+{ $values
+ { "a" sequence } { "b" sequence }
+}
+{ $description "Throws an error if all the elements of two sequences, taken pairwise, are not equal." }
+{ $notes "The sequences need not be of the same type." }
+{ $examples
+ { $example
+ "USING: prettyprint sequences ;"
+ "{ 1 2 3 } V{ 1 2 3 } assert-sequence="
+ ""
+ }
+} ;
+
ARTICLE: "sequences-unsafe" "Unsafe sequence operations"
"The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance."
$nl
{ $subsection virtual@ } ;
ARTICLE: "virtual-sequences" "Virtual sequences"
-"Virtual sequences allow different ways of accessing a sequence without having to create a new sequence or a new data structure altogether. To do this, they translate the virtual index into a normal index into an underlying sequence using the " { $link "virtual-sequences-protocol" } "."
+"A virtual sequence is an implementation of the " { $link "sequence-protocol" } " which does not store its own elements, and instead computes them, either from scratch or by retrieving them from another sequence."
+$nl
+"Implementations include the following:"
+{ $list
+ { $link reversed }
+ { $link slice }
+ { $link iota }
+}
+"Virtual sequences can be implemented with the " { $link "virtual-sequences-protocol" } ", by translating an index in the virtual sequence into an index in another sequence:"
{ $subsection "virtual-sequences-protocol" } ;
ARTICLE: "sequences-integers" "Counted loops"
{ $subsection pad-tail } ;
ARTICLE: "sequences-slices" "Subsequences and slices"
+"There are two ways to extract a subrange of elements from a sequence. The first approach creates a new sequence of the same type as the input, which does not share storage with the underlying sequence. This takes time proportional to the number of elements being extracted. The second approach creates a " { $emphasis "slice" } ", which is a virtual sequence (see " { $link "virtual-sequences" } ") sharing storage with the original sequence. Slices are constructed in constant time."
+$nl
+"Some general guidelines for choosing between the two approaches:"
+{ $list
+ "If you are using mutable state, the choice has to be made one way or another because of semantics; mutating a slice will change the underlying sequence."
+ { "Using a slice can improve algorithmic complexity. For example, if each iteration of a loop decomposes a sequence using " { $link first } " and " { $link rest } ", then the loop will run in quadratic time, relative to the length of the sequence. Using " { $link rest-slice } " changes the loop to run in linear time, since " { $link rest-slice } " does not copy any elements. Taking a slice of a slice will “collapse” the slice so to avoid the double indirection, so it is safe to use slices in recursive code." }
+ "Accessing elements from a concrete sequence (such as a string or an array) is often faster than accessing elements from a slice, because slice access entails additional indirection. However, in some cases, if the slice is immediately consumed by an iteration combinator, the compiler can eliminate the slice allocation and indirect altogether."
+ "If the slice outlives the original sequence, the original sequence will still remain in memory, since the slice will reference it. This can increase memory consumption unnecessarily."
+}
+{ $heading "Subsequence operations" }
"Extracting a subsequence:"
{ $subsection subseq }
{ $subsection head }
{ $subsection unclip-last }
{ $subsection cut }
{ $subsection cut* }
-"A " { $emphasis "slice" } " is a virtual sequence which presents as view of a subsequence of an underlying sequence:"
+{ $heading "Slice operations" }
+"The slice data type:"
{ $subsection slice }
{ $subsection slice? }
"Extracting a slice:"
{ $subsection sequence= }
{ $subsection mismatch }
{ $subsection drop-prefix }
+{ $subsection assert-sequence= }
"The " { $link <=> } " generic word performs lexicographic comparison when applied to sequences." ;
ARTICLE: "sequences-f" "The f object as a sequence"
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
: last ( seq -- elt ) [ length 1 - ] [ nth ] bi ;
+: set-last ( elt seq -- ) [ length 1 - ] keep set-nth ;
+
: pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ;
<PRIVATE
: array-flip ( matrix -- newmatrix )
{ array } declare
[ dup first array-length [ array-length min ] reduce ] keep
- [ [ array-nth ] with { } map-as ] curry { } map-as ;
+ [ [ { array } declare array-nth ] with { } map-as ] curry { } map-as ;
PRIVATE>
"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
\ 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 alien.cxx.parser alien.marshall
+alien.inline.types classes.mixin classes.tuple kernel namespaces
+assocs sequences parser classes.parser alien.marshall.syntax
+interpolate locals effects io strings make vocabs.parser words
+generic fry quotations ;
+IN: alien.cxx
+
+<PRIVATE
+: class-mixin ( str -- word )
+ create-class-in [ define-mixin-class ] keep ;
+
+: class-tuple-word ( word -- word' )
+ "#" append create-in ;
+
+: define-class-tuple ( word mixin -- )
+ [ drop class-wrapper { } define-tuple-class ]
+ [ add-mixin-instance ] 2bi ;
+PRIVATE>
+
+: define-c++-class ( name superclass-mixin -- )
+ [ [ class-tuple-word ] [ class-mixin ] bi dup ] dip
+ add-mixin-instance define-class-tuple ;
+
+:: define-c++-method ( class-name generic name types effect virtual -- )
+ [ name % "_" % class-name { { CHAR: : CHAR: _ } } substitute % ] "" make :> name'
+ effect [ in>> "self" suffix ] [ out>> ] bi <effect> :> effect'
+ types class-name "*" append suffix :> types'
+ effect in>> "," join :> args
+ class-name virtual [ "#" append ] unless current-vocab lookup :> class
+ SBUF" " clone dup [ I[ return self->${name}(${args});]I ] with-output-stream >string :> body
+ name' types' effect' body define-c-marshalled
+ class generic create-method name' current-vocab lookup 1quotation define ;
--- /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: parser lexer alien.inline ;
+IN: alien.cxx.parser
+
+: parse-c++-class-definition ( -- class superclass-mixin )
+ scan scan-word ;
+
+: parse-c++-method-definition ( -- class-name generic name types effect )
+ scan scan-word function-types-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: tools.test alien.cxx.syntax alien.inline.syntax
+alien.marshall.syntax alien.marshall accessors kernel ;
+IN: alien.cxx.syntax.tests
+
+DELETE-C-LIBRARY: test
+C-LIBRARY: test
+
+COMPILE-AS-C++
+
+C-INCLUDE: <string>
+
+C-TYPEDEF: std::string string
+
+C++-CLASS: std::string c++-root
+
+GENERIC: to-string ( obj -- str )
+
+C++-METHOD: std::string to-string const-char* c_str ( )
+
+CM-FUNCTION: std::string* new_string ( const-char* s )
+ return new std::string(s);
+;
+
+;C-LIBRARY
+
+ALIAS: <std::string> new_string
+
+{ 1 1 } [ new_string ] must-infer-as
+{ 1 1 } [ c_str_std__string ] must-infer-as
+[ t ] [ "abc" <std::string> std::string? ] unit-test
+[ "abc" ] [ "abc" <std::string> to-string ] unit-test
+
+
+DELETE-C-LIBRARY: inheritance
+C-LIBRARY: inheritance
+
+COMPILE-AS-C++
+
+C-INCLUDE: <cstring>
+
+<RAW-C
+class alpha {
+ public:
+ alpha(const char* s) {
+ str = s;
+ };
+ const char* render() {
+ return str;
+ };
+ virtual const char* chop() {
+ return str;
+ };
+ virtual int length() {
+ return strlen(str);
+ };
+ const char* str;
+};
+
+class beta : alpha {
+ public:
+ beta(const char* s) : alpha(s + 1) { };
+ const char* render() {
+ return str + 1;
+ };
+ virtual const char* chop() {
+ return str + 2;
+ };
+};
+RAW-C>
+
+C++-CLASS: alpha c++-root
+C++-CLASS: beta alpha
+
+CM-FUNCTION: alpha* new_alpha ( const-char* s )
+ return new alpha(s);
+;
+
+CM-FUNCTION: beta* new_beta ( const-char* s )
+ return new beta(s);
+;
+
+ALIAS: <alpha> new_alpha
+ALIAS: <beta> new_beta
+
+GENERIC: render ( obj -- obj )
+GENERIC: chop ( obj -- obj )
+GENERIC: length ( obj -- n )
+
+C++-METHOD: alpha render const-char* render ( )
+C++-METHOD: beta render const-char* render ( )
+C++-VIRTUAL: alpha chop const-char* chop ( )
+C++-VIRTUAL: beta chop const-char* chop ( )
+C++-VIRTUAL: alpha length int length ( )
+
+;C-LIBRARY
+
+{ 1 1 } [ render_alpha ] must-infer-as
+{ 1 1 } [ chop_beta ] must-infer-as
+{ 1 1 } [ length_alpha ] must-infer-as
+[ t ] [ "x" <alpha> alpha#? ] unit-test
+[ t ] [ "x" <alpha> alpha? ] unit-test
+[ t ] [ "x" <beta> alpha? ] unit-test
+[ f ] [ "x" <beta> alpha#? ] unit-test
+[ 5 ] [ "hello" <alpha> length ] unit-test
+[ 4 ] [ "hello" <beta> length ] unit-test
+[ "hello" ] [ "hello" <alpha> render ] unit-test
+[ "llo" ] [ "hello" <beta> render ] unit-test
+[ "ello" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying render ] unit-test
+[ "hello" ] [ "hello" <alpha> chop ] unit-test
+[ "lo" ] [ "hello" <beta> chop ] unit-test
+[ "lo" ] [ "hello" <beta> underlying>> \ alpha# new swap >>underlying chop ] unit-test
--- /dev/null
+! Copyright (C) 2009 Jeremy Hughes.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.cxx alien.cxx.parser ;
+IN: alien.cxx.syntax
+
+SYNTAX: C++-CLASS:
+ parse-c++-class-definition define-c++-class ;
+
+SYNTAX: C++-METHOD:
+ parse-c++-method-definition f define-c++-method ;
+
+SYNTAX: C++-VIRTUAL:
+ parse-c++-method-definition t define-c++-method ;
--- /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 ] [ "c-library" set ] bi
+ 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 code RAW-C>" }
+{ $description "Insert a (multiline) 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 "RAW-C>" parse-multiline-string 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 strings peg.ebnf make ;
+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? ;
+
+: template-class? ( str -- ? )
+ [ CHAR: < = ] any? ;
+
+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> ;
+
+TUPLE: c++-type name params ptr ;
+C: <c++-type> c++-type
+
+EBNF: (parse-c++-type)
+dig = [0-9]
+alpha = [a-zA-Z]
+alphanum = [1-9a-zA-Z]
+name = [_a-zA-Z] [_a-zA-Z1-9:]* => [[ first2 swap prefix >string ]]
+ptr = [*&] => [[ empty? not ]]
+
+param = "," " "* type " "* => [[ third ]]
+
+params = "<" " "* type " "* param* ">" => [[ [ 4 swap nth ] [ third ] bi prefix ]]
+
+type = name " "* params? " "* ptr? => [[ { 0 2 4 } [ swap nth ] with map first3 <c++-type> ]]
+;EBNF
+
+: parse-c++-type ( str -- c++-type )
+ factorize-type (parse-c++-type) ;
+
+DEFER: c++-type>string
+
+: params>string ( params -- str )
+ [ "<" % [ c++-type>string ] map "," join % ">" % ] "" make ;
+
+: c++-type>string ( c++-type -- str )
+ [
+ [ name>> % ]
+ [ params>> [ params>string % ] when* ]
+ [ ptr>> [ "*" % ] when ]
+ tri
+ ] "" make ;
+
+GENERIC: c++-type ( obj -- c++-type/f )
+
+M: object c++-type drop f ;
+
+M: c++-type c-type ;
--- /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: class-unmarshaller
+{ $values
+ { "type" " a C type string" }
+ { "quot/f" 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/f" 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 unmarshaller }
+"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
+locals generalizations math ;
+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 ;
+TUPLE: class-wrapper < alien-wrapper disposed ;
+
+MIXIN: c++-root
+
+GENERIC: unmarshall-cast ( alien-wrapper -- alien-wrapper' )
+
+M: alien-wrapper unmarshall-cast ;
+M: struct-wrapper unmarshall-cast ;
+
+M: struct-wrapper dispose* underlying>> free ;
+
+M: class-wrapper c++-type class name>> parse-c++-type ;
+
+: 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 ;
+
+:: x-unmarshaller ( type type-quot superclass def clean -- quot/f )
+ type type-quot call current-vocab lookup [
+ dup superclasses superclass swap member?
+ [ def call ] [ drop clean call f ] if
+ ] [ clean call f ] if* ; inline
+
+: struct-unmarshaller ( type -- quot/f )
+ [ ] \ struct-wrapper
+ [ '[ ?malloc-byte-array _ new swap >>underlying ] ]
+ [ ]
+ x-unmarshaller ;
+
+: class-unmarshaller ( type -- quot/f )
+ [ type-sans-pointer "#" append ] \ class-wrapper
+ [ '[ _ new swap >>underlying ] ]
+ [ ]
+ x-unmarshaller ;
+
+: non-primitive-unmarshaller ( type -- quot/f )
+ {
+ { [ dup pointer? ] [ class-unmarshaller ] }
+ [ struct-unmarshaller ]
+ } cond ;
+
+: unmarshaller ( type -- quot )
+ factorize-type {
+ [ primitive-unmarshaller ]
+ [ non-primitive-unmarshaller ]
+ [ drop [ ] ]
+ } 1|| ;
+
+: struct-field-unmarshaller ( type -- quot )
+ factorize-type {
+ [ struct-primitive-unmarshaller ]
+ [ non-primitive-unmarshaller ]
+ [ drop [ ] ]
+ } 1|| ;
+
+: 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) ;
IN: bson.reader
TUPLE: element { type integer } name ;
TUPLE: state
- { size initial: -1 } { read initial: 0 } exemplar
+ { size initial: -1 } exemplar
result scope element ;
: <state> ( exemplar -- state )
clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
V{ } clone [ T_Object "" element boa swap push ] keep >>element ;
-PREDICATE: bson-eoo < integer T_EOO = ;
PREDICATE: bson-not-eoo < integer T_EOO > ;
+PREDICATE: bson-eoo < integer T_EOO = ;
-PREDICATE: bson-double < integer T_Double = ;
-PREDICATE: bson-integer < integer T_Integer = ;
PREDICATE: bson-string < integer T_String = ;
PREDICATE: bson-object < integer T_Object = ;
+PREDICATE: bson-oid < integer T_OID = ;
PREDICATE: bson-array < integer T_Array = ;
+PREDICATE: bson-integer < integer T_Integer = ;
+PREDICATE: bson-double < integer T_Double = ;
+PREDICATE: bson-date < integer T_Date = ;
PREDICATE: bson-binary < integer T_Binary = ;
+PREDICATE: bson-boolean < integer T_Boolean = ;
PREDICATE: bson-regexp < integer T_Regexp = ;
+PREDICATE: bson-null < integer T_NULL = ;
+PREDICATE: bson-ref < integer T_DBRef = ;
PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ;
PREDICATE: bson-binary-function < integer T_Binary_Function = ;
PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ;
PREDICATE: bson-binary-custom < integer T_Binary_Custom = ;
-PREDICATE: bson-oid < integer T_OID = ;
-PREDICATE: bson-boolean < integer T_Boolean = ;
-PREDICATE: bson-date < integer T_Date = ;
-PREDICATE: bson-null < integer T_NULL = ;
-PREDICATE: bson-ref < integer T_DBRef = ;
GENERIC: element-read ( type -- cont? )
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
-: count-bytes ( count -- )
- [ get-state ] dip '[ _ + ] change-read drop ; inline
-
: read-int32 ( -- int32 )
- 4 [ read byte-array>number ] [ count-bytes ] bi ; inline
+ 4 read signed-le> ; inline
: read-longlong ( -- longlong )
- 8 [ read byte-array>number ] [ count-bytes ] bi ; inline
+ 8 read signed-le> ; inline
: read-double ( -- double )
- 8 [ read byte-array>number bits>double ] [ count-bytes ] bi ; inline
+ 8 read le> bits>double ; inline
: read-byte-raw ( -- byte-raw )
- 1 [ read ] [ count-bytes ] bi ; inline
+ 1 read ; inline
: read-byte ( -- byte )
read-byte-raw first ; inline
+: utf8-read-until ( seps stream encoding -- string/f sep/f )
+ [ { utf8 } declare decode-char dup [ dup rot member? ] [ 2drop f t ] if ]
+ 3curry (read-until) ;
+
: read-cstring ( -- string )
- input-stream get utf8 <decoder>
- "\0" swap stream-read-until drop ; inline
+ "\0" input-stream get utf8 utf8-read-until drop ; inline
: read-sized-string ( length -- string )
drop read-cstring ; inline
M: bson-object element-data-read ( type -- object )
(object-data-read) ;
-M: bson-array element-data-read ( type -- object )
- (object-data-read) ;
-
M: bson-string element-data-read ( type -- object )
drop
read-int32 read-sized-string ;
+M: bson-array element-data-read ( type -- object )
+ (object-data-read) ;
+
M: bson-integer element-data-read ( type -- object )
drop
read-int32 ;
USE: tools.continuations
-: stream>assoc ( exemplar -- assoc bytes-read )
+: stream>assoc ( exemplar -- assoc )
<state> dup state
[ read-int32 >>size read-elements ] with-variable
- [ result>> ] [ read>> ] bi ;
+ result>> ;
namespaces quotations sequences sequences.private serialize strings
words combinators.short-circuit literals ;
+FROM: io.encodings.utf8.private => char>utf8 ;
+FROM: kernel.private => declare ;
+
IN: bson.writer
<PRIVATE
SYMBOL: shared-buffer
+CONSTANT: CHAR-SIZE 1
CONSTANT: INT32-SIZE 4
-CONSTANT: CHAR-SIZE 1
CONSTANT: INT64-SIZE 8
: (buffer) ( -- buffer )
shared-buffer get
- [ 8192 <byte-vector> [ shared-buffer set ] keep ] unless* ; inline
-
-: >le-stream ( x n -- )
- swap
- '[ _ swap nth-byte 0 B{ 0 }
- [ set-nth-unsafe ] keep write ] each ; inline
-
+ [ BV{ } clone [ shared-buffer set ] keep ] unless*
+ { byte-vector } declare ; inline
+
PRIVATE>
: reset-buffer ( buffer -- )
: ensure-buffer ( -- )
(buffer) drop ; inline
-: with-buffer ( quot -- byte-vector )
+: with-buffer ( quot: ( -- ) -- byte-vector )
[ (buffer) [ reset-buffer ] keep dup ] dip
- with-output-stream* dup encoder? [ stream>> ] when ; inline
+ with-output-stream* ; inline
: with-length ( quot: ( -- ) -- bytes-written start-index )
- [ (buffer) [ length ] keep ] dip call
- length swap [ - ] keep ; inline
+ [ (buffer) [ length ] keep ] dip
+ call length swap [ - ] keep ; inline
-: with-length-prefix ( quot: ( -- ) -- )
- [ B{ 0 0 0 0 } write ] prepose with-length
- [ INT32-SIZE >le ] dip (buffer)
- '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
- [ INT32-SIZE ] dip each-integer ; inline
+: (with-length-prefix) ( quot: ( -- ) length-quot: ( bytes-written -- length ) -- )
+ [ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap
+ [ call ] dip (buffer) copy ; inline
+: with-length-prefix ( quot: ( -- ) -- )
+ [ INT32-SIZE >le ] (with-length-prefix) ; inline
+
: with-length-prefix-excl ( quot: ( -- ) -- )
- [ B{ 0 0 0 0 } write ] prepose with-length
- [ INT32-SIZE - INT32-SIZE >le ] dip (buffer)
- '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
- [ INT32-SIZE ] dip each-integer ; inline
+ [ INT32-SIZE [ - ] keep >le ] (with-length-prefix) ; inline
<PRIVATE
-GENERIC: bson-type? ( obj -- type ) foldable flushable
-GENERIC: bson-write ( obj -- )
+GENERIC: bson-type? ( obj -- type )
+GENERIC: bson-write ( obj -- )
M: t bson-type? ( boolean -- type ) drop T_Boolean ;
M: f bson-type? ( boolean -- type ) drop T_Boolean ;
-M: real bson-type? ( real -- type ) drop T_Double ;
-M: tuple bson-type? ( tuple -- type ) drop T_Object ;
-M: sequence bson-type? ( seq -- type ) drop T_Array ;
M: string bson-type? ( string -- type ) drop T_String ;
M: integer bson-type? ( integer -- type ) drop T_Integer ;
M: assoc bson-type? ( assoc -- type ) drop T_Object ;
+M: real bson-type? ( real -- type ) drop T_Double ;
+M: tuple bson-type? ( tuple -- type ) drop T_Object ;
+M: sequence bson-type? ( seq -- type ) drop T_Array ;
M: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
-: write-utf8-string ( string -- )
- output-stream get utf8 <encoder> stream-write ; inline
+: write-utf8-string ( string -- ) output-stream get '[ _ swap char>utf8 ] each ; inline
-: write-byte ( byte -- ) CHAR-SIZE >le-stream ; inline
-: write-int32 ( int -- ) INT32-SIZE >le-stream ; inline
-: write-double ( real -- ) double>bits INT64-SIZE >le-stream ; inline
-: write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline
-: write-longlong ( object -- ) INT64-SIZE >le-stream ; 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 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 ;
-
-M: string bson-write ( obj -- )
- '[ _ write-cstring ] with-length-prefix-excl ;
+ 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 -- )
[ '[ _ bson-write ] with-buffer ] with-scope ; inline
: assoc>stream ( assoc -- )
- bson-write ; inline
+ { assoc } declare bson-write ; inline
: mdb-special-value? ( value -- ? )
{ [ timestamp? ] [ quotation? ] [ mdbregexp? ]
- [ oid? ] [ byte-array? ] } 1|| ;
\ No newline at end of file
+ [ oid? ] [ byte-array? ] } 1|| ; inline
\ No newline at end of file
framebuffer framebuffer-dim ;
: outlining-supported? ( -- ? )
- "2.0" {
+ "3.0" {
"GL_ARB_shader_objects"
"GL_ARB_draw_buffers"
"GL_ARB_multitexture"
- } has-gl-version-or-extensions? {
"GL_EXT_framebuffer_object"
"GL_ARB_texture_float"
- } has-gl-extensions? and ;
+ } has-gl-version-or-extensions? ;
: pass1-program ( -- program )
vertex-shader-source <vertex-shader> check-gl-shader
GL_TEXTURE_2D 0 iformat dim first2 0 xformat GL_UNSIGNED_BYTE f glTexImage2D ;
:: (attach-framebuffer-texture) ( texture attachment -- )
- GL_FRAMEBUFFER_EXT attachment GL_TEXTURE_2D texture 0 glFramebufferTexture2DEXT
+ GL_DRAW_FRAMEBUFFER attachment GL_TEXTURE_2D texture 0 glFramebufferTexture2D
gl-error ;
: (make-framebuffer) ( color-texture normal-texture depth-texture -- framebuffer )
3array gen-framebuffer dup [
- swap GL_COLOR_ATTACHMENT0_EXT
- GL_COLOR_ATTACHMENT1_EXT
- GL_DEPTH_ATTACHMENT_EXT 3array [ (attach-framebuffer-texture) ] 2each
+ swap GL_COLOR_ATTACHMENT0
+ GL_COLOR_ATTACHMENT1
+ GL_DEPTH_ATTACHMENT 3array [ (attach-framebuffer-texture) ] 2each
check-framebuffer
] with-framebuffer ;
: (make-framebuffer-textures) ( draw dim -- draw color normal depth )
{
[ drop ]
- [ GL_RGBA16F_ARB GL_RGBA [ >>color-texture ] (framebuffer-texture>>draw) ]
- [ GL_RGBA16F_ARB GL_RGBA [ >>normal-texture ] (framebuffer-texture>>draw) ]
+ [ GL_RGBA16F GL_RGBA [ >>color-texture ] (framebuffer-texture>>draw) ]
+ [ GL_RGBA16F GL_RGBA [ >>normal-texture ] (framebuffer-texture>>draw) ]
[
GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT
[ >>depth-texture ] (framebuffer-texture>>draw)
[ drop ] [ remake-framebuffer ] if ;
: clear-framebuffer ( -- )
- GL_COLOR_ATTACHMENT0_EXT glDrawBuffer
+ GL_COLOR_ATTACHMENT0 glDrawBuffer
0.15 0.15 0.15 1.0 glClearColor
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
- GL_COLOR_ATTACHMENT1_EXT glDrawBuffer
+ GL_COLOR_ATTACHMENT1 glDrawBuffer
0.0 0.0 0.0 0.0 glClearColor
GL_COLOR_BUFFER_BIT glClear ;
: (pass1) ( geom draw -- )
dup framebuffer>> [
clear-framebuffer
- { GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers
+ { GL_COLOR_ATTACHMENT0 GL_COLOR_ATTACHMENT1 } set-draw-buffers
pass1-program>> (draw-cel-shaded-bunny)
] with-framebuffer ;
--- /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
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: assocs classes help.markup help.syntax kernel math
+quotations strings ;
+IN: combinators.tuple
+
+HELP: 2make-tuple
+{ $values
+ { "x" object } { "y" object } { "class" class } { "assoc" assoc }
+ { "tuple" tuple }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } " and " { $snippet "y" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x y -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
+
+HELP: 3make-tuple
+{ $values
+ { "x" object } { "y" object } { "z" object } { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" }
+ { "tuple" tuple }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } ", " { $snippet "y" } ", and " { $snippet "z" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x y z -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
+
+HELP: make-tuple
+{ $values
+ { "x" object } { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" }
+ { "tuple" tuple }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on " { $snippet "x" } ", assigning the result of each call to the slot named by the corresponding key. The quotations must have the effect " { $snippet "( x -- slot-value )" } ". The order in which the quotations is called is undefined." } ;
+
+HELP: nmake-tuple
+{ $values
+ { "class" class } { "assoc" "a list of " { $link string } "/" { $link quotation } " pairs" } { "n" integer }
+}
+{ $description "Constructs a " { $link tuple } " of " { $snippet "class" } " by calling the quotations making up the values of " { $snippet "assoc" } " on the top " { $snippet "n" } " values on the datastack below " { $snippet "class" } ", assigning the result of each call to the slot named by the corresponding key. The order in which the quotations is called is undefined." } ;
+
+{ make-tuple 2make-tuple 3make-tuple nmake-tuple } related-words
+
+ARTICLE: "combinators.tuple" "Tuple-constructing combinators"
+"The " { $vocab-link "combinators.tuple" } " vocabulary provides dataflow combinators that construct " { $link tuple } " objects."
+{ $subsection make-tuple }
+{ $subsection 2make-tuple }
+{ $subsection 3make-tuple }
+{ $subsection nmake-tuple }
+;
+
+ABOUT: "combinators.tuple"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors assocs classes.tuple generalizations kernel
+locals quotations sequences ;
+IN: combinators.tuple
+
+<PRIVATE
+
+:: (tuple-slot-quot) ( slot assoc n -- quot )
+ slot name>> assoc at [
+ slot initial>> :> initial
+ { n ndrop initial } >quotation
+ ] unless* ;
+
+PRIVATE>
+
+MACRO:: nmake-tuple ( class assoc n -- )
+ class all-slots [ assoc n (tuple-slot-quot) ] map :> quots
+ class <wrapper> :> \class
+ { quots n ncleave \class boa } >quotation ;
+
+: make-tuple ( x class assoc -- tuple )
+ 1 nmake-tuple ; inline
+
+: 2make-tuple ( x y class assoc -- tuple )
+ 2 nmake-tuple ; inline
+
+: 3make-tuple ( x y z class assoc -- tuple )
+ 3 nmake-tuple ; inline
+
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license
+USING: accessors compiler.cfg.rpo compiler.cfg.dominance
+compiler.cfg.dominance.private compiler.cfg.predecessors images.viewer
+io io.encodings.ascii io.files io.files.unique io.launcher kernel
+math.parser sequences assocs arrays make namespaces ;
+IN: compiler.cfg.graphviz
+
+: render-graph ( edges -- )
+ "cfg" "dot" make-unique-file
+ [
+ ascii [
+ "digraph CFG {" print
+ [ [ number>> number>string ] bi@ " -> " glue write ";" print ] assoc-each
+ "}" print
+ ] with-file-writer
+ ]
+ [ { "dot" "-Tpng" "-O" } swap suffix try-process ]
+ [ ".png" append { "open" } swap suffix try-process ]
+ tri ;
+
+: cfg-edges ( cfg -- edges )
+ [
+ [
+ dup successors>> [
+ 2array ,
+ ] with each
+ ] each-basic-block
+ ] { } make ;
+
+: render-cfg ( cfg -- ) cfg-edges render-graph ;
+
+: dom-edges ( cfg -- edges )
+ [
+ compute-predecessors
+ compute-dominance
+ dom-childrens get [
+ [
+ 2array ,
+ ] with each
+ ] assoc-each
+ ] { } make ;
+
+: render-dom ( cfg -- ) dom-edges render-graph ;
\ No newline at end of file
[ 1 + ] change-a ;
CONSTRUCTOR: ct2 ( a b -- obj )
- initialize-ct1
[ 1 + ] change-a ;
CONSTRUCTOR: ct3 ( a b c -- obj )
- initialize-ct1
[ 1 + ] change-a ;
CONSTRUCTOR: ct4 ( a b c d -- obj )
- initialize-ct3
[ 1 + ] change-a ;
[ 1001 ] [ 1000 <ct1> a>> ] unit-test
[ 2 ] [ 0 0 <ct2> a>> ] unit-test
-[ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
-[ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test
-
-
-TUPLE: rofl a b c ;
-CONSTRUCTOR: rofl ( b c a -- obj ) ;
-
-[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 <rofl> ] unit-test
-
-
-TUPLE: default { a integer initial: 0 } ;
-
-CONSTRUCTOR: default ( -- obj ) ;
-
-[ 0 ] [ <default> a>> ] unit-test
-
-
-TUPLE: inherit1 a ;
-TUPLE: inherit2 < inherit1 a ;
-
-CONSTRUCTOR: inherit2 ( a -- obj ) ;
-
-[ T{ inherit2 f f 100 } ] [ 100 <inherit2> ] unit-test
-
-
-TUPLE: inherit3 hp max-hp ;
-TUPLE: inherit4 < inherit3 ;
-TUPLE: inherit5 < inherit3 ;
-
-CONSTRUCTOR: inherit3 ( -- obj )
- dup max-hp>> >>hp ;
-
-BACKWARD-CONSTRUCTOR: inherit4 ( -- obj )
- 10 >>max-hp ;
-
-[ 10 ] [ <inherit4> hp>> ] unit-test
-
-FORWARD-CONSTRUCTOR: inherit5 ( -- obj )
- 5 >>hp
- 10 >>max-hp ;
-
-[ 5 ] [ <inherit5> hp>> ] unit-test
+[ 3 ] [ 0 0 0 <ct3> a>> ] unit-test
+[ 4 ] [ 0 0 0 0 <ct4> a>> ] unit-test
class def define-initializer
class effect in>> '[ _ _ slots>constructor ] ;
-:: define-constructor ( constructor-word class effect def -- )
- constructor-word class effect def (define-constructor)
- class lookup-initializer
- '[ @ _ execute( obj -- obj ) ] effect define-declared ;
-
-:: define-auto-constructor ( constructor-word class effect def reverse? -- )
+:: define-constructor ( constructor-word class effect def reverse? -- )
constructor-word class effect def (define-constructor)
class superclasses [ lookup-initializer ] map sift
reverse? [ reverse ] when
: parse-constructor ( -- class word effect def )
scan-constructor complete-effect parse-definition ;
-SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ;
-SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
-SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ;
-SYNTAX: AUTO-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
+SYNTAX: CONSTRUCTOR: parse-constructor f define-constructor ;
"initializers" create-vocab drop
: 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-range>
+{ $values
+ { "buffer" buffer } { "offset" integer } { "size" integer }
+ { "buffer-range" buffer-range }
+}
+{ $description "Constructs a " { $link buffer-range } " 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." }
+{ "A " { $link transform-feedback-buffer } " is used as a destination for transform feedback output from a vertex shader." }
+} }
+{ $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-ptr>range
+{ $values
+ { "buffer-ptr" buffer-ptr }
+ { "buffer-range" buffer-range }
+}
+{ $description "Converts a " { $link buffer-ptr } " into a " { $link buffer-range } " spanning from the " { $snippet "offset" } " referenced by the " { $snippet "buffer-ptr" } " to the end of the underlying " { $link buffer } "." } ;
+
+HELP: buffer-range
+{ $class-description "A " { $snippet "buffer-range" } " references a subset of a " { $link buffer } " object's memory. " { $snippet "buffer-range" } "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 to the beginning of the referenced range." }
+{ { $snippet "size" } " is the integer length from the beginning offset to the end of the referenced range." }
+} } ;
+
+{ buffer-ptr buffer-range } related-words
+
+HELP: buffer-size
+{ $values
+ { "buffer" buffer }
+ { "size" integer }
+}
+{ $description "Returns the size in bytes of the memory currently allocated for a " { $link buffer } " object." } ;
+
+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: transform-feedback-buffer
+{ $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be to receive transform feedback output from a render job." }
+{ $notes "Transform feedback requires OpenGL 3.0 or one of the " { $snippet "GL_EXT_transform_feedback" } " or " { $snippet "GL_ARB_transform_feedback" } " extensions." } ;
+
+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 transform-feedback-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 buffer-size 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 }
+{ $subsection buffer-range }
+"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
+ transform-feedback-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 ] }
+ { transform-feedback-buffer [ GL_TRANSFORM_FEEDBACK_BUFFER ] }
+ } case ; inline
+
+: get-buffer-int ( target enum -- value )
+ 0 <int> [ glGetBufferParameteriv ] keep *int ;
+
+: bind-buffer ( buffer -- target )
+ [ kind>> gl-target dup ] [ handle>> glBindBuffer ] bi ;
+
+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
+
+TUPLE: buffer-range < buffer-ptr
+ { size integer read-only } ;
+C: <buffer-range> buffer-range
+
+UNION: gpu-data-ptr buffer-ptr c-ptr ;
+
+: buffer-size ( buffer -- size )
+ bind-buffer GL_BUFFER_SIZE get-buffer-int ;
+
+: buffer-ptr>range ( buffer-ptr -- buffer-range )
+ [ buffer>> ] [ offset>> ] bi
+ 2dup [ buffer-size ] dip -
+ buffer-range boa ; inline
+
+:: allocate-buffer ( buffer size initial-data -- )
+ buffer bind-buffer :> target
+ 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 bind-buffer :> target
+ target buffer-ptr offset>> size data glBufferSubData ;
+
+:: read-buffer ( buffer-ptr size -- data )
+ buffer-ptr buffer>> :> buffer
+ buffer bind-buffer :> target
+ size <byte-array> :> data
+ 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 bind-buffer :> target
+ 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
+! (c)2009 Joe Groff bsd license
+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" vec3-uniform f }
+ { "color" vec4-uniform f }
+ { "ambient" vec4-uniform f }
+ { "diffuse" vec4-uniform f }
+ { "shininess" float-uniform f } ;
+
+UNIFORM-TUPLE: sobel-uniforms
+ { "texcoord-scale" vec2-uniform f }
+ { "color-texture" texture-uniform f }
+ { "normal-texture" texture-uniform f }
+ { "depth-texture" texture-uniform f }
+ { "line-color" vec4-uniform f } ;
+
+UNIFORM-TUPLE: loading-uniforms
+ { "texcoord-scale" vec2-uniform f }
+ { "loading-texture" texture-uniform f } ;
+
+: 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
+ ] [
+ {
+ { "primitive-mode" [ drop triangles-mode ] }
+ { "output-attachments" [ drop { T{ color-attachment f 0 } T{ color-attachment f 1 } } ] }
+ { "uniforms" [ <bunny-uniforms> ] }
+ { "vertex-array" [ bunny>> vertex-array>> ] }
+ { "indexes" [ bunny>> index-elements>> ] }
+ { "framebuffer" [ sobel>> framebuffer>> ] }
+ } <render-set> 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*
+
+ sobel>> {
+ { "primitive-mode" [ drop triangle-strip-mode ] }
+ { "indexes" [ drop T{ index-range f 0 4 } ] }
+ { "uniforms" [ <sobel-uniforms> ] }
+ { "vertex-array" [ vertex-array>> ] }
+ } <render-set> render ;
+
+: draw-sobeled-bunny ( world -- )
+ [ draw-bunny ] [ draw-sobel ] bi ;
+
+: draw-loading ( world -- )
+ T{ depth-state { comparison f } } set-gpu-state*
+
+ loading>> {
+ { "primitive-mode" [ drop triangle-strip-mode ] }
+ { "indexes" [ drop T{ index-range f 0 4 } ] }
+ { "uniforms" [ { 1.0 -1.0 } swap texture>> loading-uniforms boa ] }
+ { "vertex-array" [ vertex-array>> ] }
+ } <render-set> 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 combinators.tuple 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: sphere-uniforms
+ { "center" vec3-uniform f }
+ { "radius" float-uniform f }
+ { "color" vec4-uniform f } ;
+
+UNIFORM-TUPLE: raytrace-uniforms
+ { "mv-inv-matrix" mat4-uniform f }
+ { "fov" vec2-uniform f }
+
+ { "spheres" sphere-uniforms 4 }
+
+ { "floor-height" float-uniform f }
+ { "floor-color" vec4-uniform 2 }
+ { "background-color" vec4-uniform f }
+ { "light-direction" vec3-uniform f } ;
+
+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 sphere-uniforms boa ] map
+ ] tri
+ -30.0 ! floor_height
+ { { 1.0 0.0 0.0 1.0 } { 1.0 1.0 1.0 1.0 } } ! floor_color
+ { 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*
+ {
+ { "primitive-mode" [ drop triangle-strip-mode ] }
+ { "indexes" [ drop T{ index-range f 0 4 } ] }
+ { "uniforms" [ <sphere-uniforms> ] }
+ { "vertex-array" [ vertex-array>> ] }
+ } <render-set> 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: 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" } " specifies an array length if not " { $link f } "."
+$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 take their values from Factor " { $link sequence } "s of the corresponding component type."
+ { $list
+ { "Float vector types: " { $link vec2-uniform } ", " { $link vec3-uniform } ", " { $link vec4-uniform } }
+ { "Integer vector types: " { $link ivec2-uniform } ", " { $link ivec3-uniform } ", " { $link ivec4-uniform } }
+ { "Unsigned integer vector types: " { $link uvec2-uniform } ", " { $link uvec3-uniform } ", " { $link uvec4-uniform } }
+ { "Boolean vector types: " { $link bvec2-uniform } ", " { $link bvec3-uniform } ", " { $link bvec4-uniform } }
+ }
+}
+{ "Matrix uniforms take their values from row-major Factor " { $link sequence } "s of sequences of floats. Matrix types are:"
+ { $list
+ { { $link mat2-uniform } ", " { $link mat2x3-uniform } ", " { $link mat2x4-uniform } }
+ { { $link mat3x2-uniform } ", " { $link mat3-uniform } ", " { $link mat3x4-uniform } }
+ { { $link mat4x2-uniform } ", " { $link mat4x3-uniform } ", " { $link mat4-uniform } }
+ }
+"Rectangular matrix type names are column x row."
+}
+{ "Uniform slots can also be defined as other " { $snippet "uniform-tuple" } " types to bind uniform structures. The uniform structure will take its value from the slots of a tuple of the given type." }
+{ "Array uniforms are passed as Factor sequences of the corresponding value type above." }
+}
+$nl
+"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: bool-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a boolean uniform parameter." } ;
+
+HELP: bvec2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component boolean vector uniform parameter." } ;
+
+HELP: bvec3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component boolean vector uniform parameter." } ;
+
+HELP: bvec4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component boolean vector uniform parameter." } ;
+
+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: float-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a float uniform parameter." } ;
+
+{ 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 } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a signed integer uniform parameter." } ;
+
+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: ivec2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component integer vector uniform parameter." } ;
+
+HELP: ivec3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component integer vector uniform parameter." } ;
+
+HELP: ivec4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component integer vector uniform parameter." } ;
+
+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: mat2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2x2 square float matrix uniform parameter." } ;
+
+HELP: mat2x3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2-column, 3-row float matrix uniform parameter." } ;
+
+HELP: mat2x4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 2-column, 4-row float matrix uniform parameter." } ;
+
+HELP: mat3x2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3-column, 2-row float matrix uniform parameter." } ;
+
+HELP: mat3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3x3 square float matrix uniform parameter." } ;
+
+HELP: mat3x4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 3-column, 4-row float matrix uniform parameter." } ;
+
+HELP: mat4x2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4-column, 2-row float matrix uniform parameter." } ;
+
+HELP: mat4x3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4-column, 3-row float matrix uniform parameter." } ;
+
+HELP: mat4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a 4x4 square float matrix uniform parameter." } ;
+
+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. " { $link f } " can also be specified to disable rasterization and only run the vertex transformation rendering stage." }
+{ "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." }
+{ "The " { $snippet "transform-feedback-output" } " slot specifies a target for transform feedback output from the vertex shader: either an entire " { $link buffer } ", a " { $link buffer-range } " subset, or a " { $link buffer-ptr } " offset into the buffer. If " { $link f } ", no transform feedback output is collected. The shader program associated with " { $snippet "vertex-array" } " must have a transform feedback output format specified." }
+} }
+{ $notes "User-created framebuffers require OpenGL 3.0 or one of the " { $snippet "GL_EXT_framebuffer_object" } " or " { $snippet "GL_ARB_framebuffer_object" } " extensions. Disabling rasterization requires OpenGL 3.0 or the " { $snippet "GL_EXT_transform_feedback" } " extension. Named output-attachment values are available in GLSL 1.30 or later, and GLSL 1.20 and earlier using the " { $snippet "GL_EXT_gpu_shader4" } " extension. Transform feedback requires OpenGL 3.0 or one of the " { $snippet "GL_EXT_transform_feedback" } " or " { $snippet "GL_ARB_transform_feedback" } " extensions." } ;
+
+{ render render-set } related-words
+
+HELP: texture-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a texture uniform parameter." } ;
+
+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 } " corresponds to an unsigned integer uniform parameter." } ;
+
+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." } ;
+
+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: uvec2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component unsigned integer vector uniform parameter." } ;
+
+HELP: uvec3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component unsigned integer vector uniform parameter." } ;
+
+HELP: uvec4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component unsigned integer vector uniform parameter." } ;
+
+HELP: vec2-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component float vector uniform parameter." } ;
+
+HELP: vec3-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a three-component float vector uniform parameter." } ;
+
+HELP: vec4-uniform
+{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a four-component float vector uniform parameter." } ;
+
+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 }
+{ $link uniform-tuple } "s provide Factor types for containing and submitting shader uniform parameters:"
+{ $subsection POSTPONE: UNIFORM-TUPLE: }
+;
+
+ABOUT: "gpu.render"
--- /dev/null
+USING: accessors combinators gpu.render gpu.render.private kernel sequences tools.test ;
+IN: gpu.render.tests
+
+UNIFORM-TUPLE: two-textures
+ { "argyle" texture-uniform f }
+ { "thread-count" float-uniform f }
+ { "tweed" texture-uniform f } ;
+
+UNIFORM-TUPLE: inherited-textures < two-textures
+ { "paisley" texture-uniform f } ;
+
+UNIFORM-TUPLE: array-of-textures < two-textures
+ { "plaids" texture-uniform 4 } ;
+
+UNIFORM-TUPLE: struct-containing-texture
+ { "threads" two-textures f } ;
+
+UNIFORM-TUPLE: array-of-struct-containing-texture
+ { "threads" inherited-textures 3 } ;
+
+UNIFORM-TUPLE: array-of-struct-containing-array-of-texture
+ { "threads" array-of-textures 2 } ;
+
+[ 1 ] [ texture-uniform uniform-type-texture-units ] unit-test
+[ 0 ] [ float-uniform uniform-type-texture-units ] unit-test
+[ 2 ] [ two-textures uniform-type-texture-units ] unit-test
+[ 3 ] [ inherited-textures uniform-type-texture-units ] unit-test
+[ 6 ] [ array-of-textures uniform-type-texture-units ] unit-test
+[ 2 ] [ struct-containing-texture uniform-type-texture-units ] unit-test
+[ 9 ] [ array-of-struct-containing-texture uniform-type-texture-units ] unit-test
+[ 12 ] [ array-of-struct-containing-array-of-texture uniform-type-texture-units ] unit-test
+
+[ { [ ] } ] [ texture-uniform f uniform-texture-accessors ] unit-test
+
+[ { } ] [ float-uniform f uniform-texture-accessors ] unit-test
+
+[ { [ argyle>> ] [ tweed>> ] } ] [ two-textures f uniform-texture-accessors ] unit-test
+
+[ { [ argyle>> ] [ tweed>> ] [ paisley>> ] } ]
+[ inherited-textures f uniform-texture-accessors ] unit-test
+
+[ {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ plaids>> {
+ [ 0 swap nth ]
+ [ 1 swap nth ]
+ [ 2 swap nth ]
+ [ 3 swap nth ]
+ } ]
+} ] [ array-of-textures f uniform-texture-accessors ] unit-test
+
+[ {
+ [ threads>> {
+ [ argyle>> ]
+ [ tweed>> ]
+ } ]
+} ] [ struct-containing-texture f uniform-texture-accessors ] unit-test
+
+[ {
+ [ threads>> {
+ [ 0 swap nth {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ paisley>> ]
+ } ]
+ [ 1 swap nth {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ paisley>> ]
+ } ]
+ [ 2 swap nth {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ paisley>> ]
+ } ]
+ } ]
+} ] [ array-of-struct-containing-texture f uniform-texture-accessors ] unit-test
+
+[ {
+ [ threads>> {
+ [ 0 swap nth {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ plaids>> {
+ [ 0 swap nth ]
+ [ 1 swap nth ]
+ [ 2 swap nth ]
+ [ 3 swap nth ]
+ } ]
+ } ]
+ [ 1 swap nth {
+ [ argyle>> ]
+ [ tweed>> ]
+ [ plaids>> {
+ [ 0 swap nth ]
+ [ 1 swap nth ]
+ [ 2 swap nth ]
+ [ 3 swap nth ]
+ } ]
+ } ]
+ } ]
+} ] [ array-of-struct-containing-array-of-texture f uniform-texture-accessors ] unit-test
+
+[ [
+ nip {
+ [ argyle>> 0 (bind-texture-unit) ]
+ [ tweed>> 1 (bind-texture-unit) ]
+ [ plaids>> {
+ [ 0 swap nth 2 (bind-texture-unit) ]
+ [ 1 swap nth 3 (bind-texture-unit) ]
+ [ 2 swap nth 4 (bind-texture-unit) ]
+ [ 3 swap nth 5 (bind-texture-unit) ]
+ } cleave ]
+ } cleave
+] ] [ array-of-textures [bind-uniform-textures] ] unit-test
+
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors alien alien.c-types alien.structs arrays
+assocs classes classes.mixin classes.parser classes.singleton
+classes.tuple classes.tuple.private combinators combinators.tuple destructors fry
+generic generic.parser gpu gpu.buffers gpu.framebuffers
+gpu.framebuffers.private gpu.shaders gpu.shaders.private 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 tr ui.gadgets.worlds variants
+vocabs.parser words ;
+IN: gpu.render
+
+UNION: ?integer integer POSTPONE: f ;
+
+VARIANT: uniform-type
+ bool-uniform
+ bvec2-uniform
+ bvec3-uniform
+ bvec4-uniform
+ uint-uniform
+ uvec2-uniform
+ uvec3-uniform
+ uvec4-uniform
+ int-uniform
+ ivec2-uniform
+ ivec3-uniform
+ ivec4-uniform
+ float-uniform
+ vec2-uniform
+ vec3-uniform
+ vec4-uniform
+
+ mat2-uniform
+ mat2x3-uniform
+ mat2x4-uniform
+
+ mat3x2-uniform
+ mat3-uniform
+ mat3x4-uniform
+
+ mat4x2-uniform
+ mat4x3-uniform
+ mat4-uniform
+
+ texture-uniform ;
+
+ALIAS: mat2x2-uniform mat2-uniform
+ALIAS: mat3x3-uniform mat3-uniform
+ALIAS: mat4x4-uniform mat4-uniform
+
+TUPLE: uniform
+ { name string read-only initial: "" }
+ { uniform-type class read-only initial: float-uniform }
+ { dim ?integer read-only initial: f } ;
+
+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
+
+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 ;
+
+TUPLE: uniform-tuple ;
+
+ERROR: invalid-uniform-type uniform ;
+
+<PRIVATE
+
+: 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 texture-unit -- )
+ swap [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
+
+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>> [ drop sequence ] [
+ uniform-type>> {
+ { bool-uniform [ boolean ] }
+ { uint-uniform [ integer ] }
+ { int-uniform [ integer ] }
+ { float-uniform [ float ] }
+ { texture-uniform [ texture ] }
+ [ drop sequence ]
+ } case
+ ] if ;
+
+: uniform>slot ( uniform -- slot )
+ [ name>> ] [ uniform-slot-type ] bi 2array ;
+
+: uniform-type-texture-units ( uniform-type -- units )
+ dup texture-uniform = [ drop 1 ] [ "uniform-tuple-texture-units" word-prop 0 or ] if ;
+
+: all-uniform-tuple-slots ( class -- slots )
+ dup "uniform-tuple-slots" word-prop
+ [ swap superclass all-uniform-tuple-slots prepend ] [ drop { } ] if* ;
+
+DEFER: uniform-texture-accessors
+
+: uniform-type-texture-accessors ( uniform-type -- accessors )
+ texture-uniform = [ { [ ] } ] [ { } ] if ;
+
+: uniform-slot-texture-accessor ( uniform -- accessor )
+ [ name>> reader-word ] [ [ uniform-type>> ] [ dim>> ] bi uniform-texture-accessors ] bi
+ dup length 1 = [ first swap prefix ] [ [ ] 2sequence ] if ;
+
+: uniform-tuple-texture-accessors ( uniform-type -- accessors )
+ all-uniform-tuple-slots [ uniform-type>> uniform-type-texture-units zero? not ] filter
+ [ uniform-slot-texture-accessor ] map ;
+
+: uniform-texture-accessors ( uniform-type dim -- accessors )
+ [
+ dup uniform-type?
+ [ uniform-type-texture-accessors ]
+ [ uniform-tuple-texture-accessors ] if
+ ] [
+ 2dup swap empty? not and [
+ iota [
+ [ swap nth ] swap prefix
+ over length 1 = [ swap first append ] [ swap suffix ] if
+ ] with map
+ ] [ drop ] if
+ ] bi* ;
+
+: texture-accessor>cleave ( unit accessors -- unit' cleaves )
+ dup last sequence?
+ [ [ last [ texture-accessor>cleave ] map ] [ but-last ] bi swap suffix \ cleave suffix ]
+ [ over suffix \ (bind-texture-unit) suffix [ 1 + ] dip ] if ;
+
+: [bind-uniform-textures] ( class -- quot )
+ f uniform-texture-accessors
+ 0 swap [ texture-accessor>cleave ] map nip
+ \ nip swap \ cleave [ ] 3sequence ;
+
+DEFER: [bind-uniform-tuple]
+
+:: [bind-uniform-array] ( value>>-quot type texture-unit name dim -- texture-unit' quot )
+ { name uniform-index } >quotation :> index-quot
+ { index-quot value>>-quot bi* } >quotation :> pre-quot
+
+ type H{
+ { bool-uniform { dim swap [ >c-bool ] int-array{ } map-as glUniform1iv } }
+ { int-uniform { dim swap >int-array glUniform1iv } }
+ { uint-uniform { dim swap >uint-array glUniform1uiv } }
+ { float-uniform { dim swap >float-array glUniform1fv } }
+
+ { bvec2-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform2iv } }
+ { ivec2-uniform { dim swap int-array{ } concat-as glUniform2i } }
+ { uvec2-uniform { dim swap uint-array{ } concat-as glUniform2ui } }
+ { vec2-uniform { dim swap float-array{ } concat-as glUniform2f } }
+
+ { bvec3-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform3iv } }
+ { ivec3-uniform { dim swap int-array{ } concat-as glUniform3i } }
+ { uvec3-uniform { dim swap uint-array{ } concat-as glUniform3ui } }
+ { vec3-uniform { dim swap float-array{ } concat-as glUniform3f } }
+
+ { bvec4-uniform { dim swap [ [ >c-bool ] map ] map int-array{ } concat-as glUniform4iv } }
+ { ivec4-uniform { dim swap int-array{ } concat-as glUniform4iv } }
+ { uvec4-uniform { dim swap uint-array{ } concat-as glUniform4uiv } }
+ { vec4-uniform { dim swap float-array{ } concat-as glUniform4fv } }
+
+ { mat2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2fv } }
+ { mat2x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2x3fv } }
+ { mat2x4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix2x4fv } }
+
+ { mat3x2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3x2fv } }
+ { mat3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3fv } }
+ { mat3x4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix3x4fv } }
+
+ { mat4x2-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x2fv } }
+ { mat4x3-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4x3fv } }
+ { mat4-uniform { [ dim 1 ] dip float-array{ } concat-as concat glUniformMatrix4fv } }
+
+ { texture-uniform { drop dim dup iota [ texture-unit + ] int-array{ } map-as glUniform1iv } }
+ } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
+
+ type uniform-type-texture-units dim * texture-unit +
+ pre-quot value-quot append ;
+
+:: [bind-uniform-value] ( value>>-quot type texture-unit name -- texture-unit' quot )
+ { name uniform-index } >quotation :> index-quot
+ { index-quot value>>-quot bi* } >quotation :> pre-quot
+
+ type H{
+ { bool-uniform [ >c-bool glUniform1i ] }
+ { int-uniform [ glUniform1i ] }
+ { uint-uniform [ glUniform1ui ] }
+ { float-uniform [ glUniform1f ] }
+
+ { bvec2-uniform [ [ >c-bool ] map first2 glUniform2i ] }
+ { ivec2-uniform [ first2 glUniform2i ] }
+ { uvec2-uniform [ first2 glUniform2ui ] }
+ { vec2-uniform [ first2 glUniform2f ] }
+
+ { bvec3-uniform [ [ >c-bool ] map first3 glUniform3i ] }
+ { ivec3-uniform [ first3 glUniform3i ] }
+ { uvec3-uniform [ first3 glUniform3ui ] }
+ { vec3-uniform [ first3 glUniform3f ] }
+
+ { bvec4-uniform [ [ >c-bool ] map first4 glUniform4i ] }
+ { ivec4-uniform [ first4 glUniform4i ] }
+ { uvec4-uniform [ first4 glUniform4ui ] }
+ { vec4-uniform [ first4 glUniform4f ] }
+
+ { mat2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2fv ] }
+ { mat2x3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2x3fv ] }
+ { mat2x4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix2x4fv ] }
+
+ { mat3x2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3x2fv ] }
+ { mat3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3fv ] }
+ { mat3x4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix3x4fv ] }
+
+ { mat4x2-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4x2fv ] }
+ { mat4x3-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4x3fv ] }
+ { mat4-uniform [ [ 1 1 ] dip float-array{ } concat-as glUniformMatrix4fv ] }
+
+ { texture-uniform { drop texture-unit glUniform1i } }
+ } at [ uniform invalid-uniform-type ] unless* >quotation :> value-quot
+
+ type uniform-type-texture-units texture-unit +
+ pre-quot value-quot append ;
+
+:: [bind-uniform-struct] ( value>>-quot type texture-unit name dim -- texture-unit' quot )
+ dim
+ [
+ iota
+ [ [ [ swap nth ] swap prefix ] map ]
+ [ [ number>string name "[" append "]." surround ] map ] bi
+ ] [
+ { [ ] }
+ name "." append 1array
+ ] if* :> name-prefixes :> quot-prefixes
+ type all-uniform-tuple-slots :> uniforms
+
+ texture-unit quot-prefixes name-prefixes [| quot-prefix name-prefix |
+ uniforms name-prefix [bind-uniform-tuple]
+ quot-prefix prepend
+ ] 2map :> value-cleave :> texture-unit'
+
+ texture-unit'
+ value>>-quot { value-cleave 2cleave } append ;
+
+TR: hyphens>underscores "-" "_" ;
+
+:: [bind-uniform] ( texture-unit uniform prefix -- texture-unit' quot )
+ prefix uniform name>> append hyphens>underscores :> name
+ uniform uniform-type>> :> type
+ uniform dim>> :> dim
+ uniform name>> reader-word 1quotation :> value>>-quot
+
+ value>>-quot type texture-unit name {
+ { [ type uniform-type? dim and ] [ dim [bind-uniform-array] ] }
+ { [ type uniform-type? dim not and ] [ [bind-uniform-value] ] }
+ [ dim [bind-uniform-struct] ]
+ } cond ;
+
+:: [bind-uniform-tuple] ( texture-unit uniforms prefix -- texture-unit' quot )
+ texture-unit uniforms [ prefix [bind-uniform] ] map :> uniforms-cleave :> texture-unit'
+
+ texture-unit'
+ { uniforms-cleave 2cleave } >quotation ;
+
+:: [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-tuple] nip :> bind-quot
+
+ { 2dup next-method } bind-quot [ ] append-as ;
+
+: define-uniform-tuple-methods ( class superclass uniforms -- )
+ [
+ 2drop
+ [ \ bind-uniform-textures create-method-in ]
+ [ [bind-uniform-textures] ] bi 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 ;
+
+: (define-uniform-tuple) ( class superclass uniforms -- )
+ {
+ [ [ uniform>slot ] map define-tuple-class ]
+ [
+ [ uniform-type-texture-units ]
+ [
+ [ [ uniform-type>> uniform-type-texture-units ] [ dim>> 1 or ] bi * ]
+ [ + ] map-reduce
+ ] bi* +
+ "uniform-tuple-texture-units" set-word-prop
+ ]
+ [ nip "uniform-tuple-slots" set-word-prop ]
+ [ define-uniform-tuple-methods ]
+ } 3cleave ;
+
+: true-subclasses ( class -- seq )
+ [ subclasses ] keep [ = not ] curry filter ;
+
+PRIVATE>
+
+: define-uniform-tuple ( class superclass uniforms -- )
+ (define-uniform-tuple) ; inline
+
+SYNTAX: UNIFORM-TUPLE:
+ parse-uniform-tuple-definition define-uniform-tuple ;
+
+<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 ;
+
+GENERIC: bind-transform-feedback-output ( output -- )
+
+M: buffer bind-transform-feedback-output
+ [ GL_TRANSFORM_FEEDBACK_BUFFER 0 ] dip handle>> glBindBufferBase ; inline
+
+M: buffer-range bind-transform-feedback-output
+ [ GL_TRANSFORM_FEEDBACK_BUFFER 0 ] dip
+ [ handle>> ] [ offset>> ] [ size>> ] tri glBindBufferRange ; inline
+
+M: buffer-ptr bind-transform-feedback-output
+ buffer-ptr>range bind-transform-feedback-output ; inline
+
+: gl-feedback-primitive-mode ( primitive-mode -- gl-mode )
+ {
+ { points-mode [ GL_POINTS ] }
+ { lines-mode [ GL_LINES ] }
+ { line-strip-mode [ GL_LINES ] }
+ { line-loop-mode [ GL_LINES ] }
+ { triangles-mode [ GL_TRIANGLES ] }
+ { triangle-strip-mode [ GL_TRIANGLES ] }
+ { triangle-fan-mode [ GL_TRIANGLES ] }
+ } case ;
+
+PRIVATE>
+
+UNION: ?any-framebuffer any-framebuffer POSTPONE: f ;
+UNION: transform-feedback-output buffer buffer-range POSTPONE: f ;
+
+TUPLE: render-set
+ { primitive-mode primitive-mode read-only }
+ { vertex-array vertex-array read-only }
+ { uniforms uniform-tuple read-only }
+ { indexes vertex-indexes initial: T{ index-range } read-only }
+ { instances ?integer initial: f read-only }
+ { framebuffer ?any-framebuffer initial: system-framebuffer read-only }
+ { output-attachments sequence initial: { default-attachment } read-only }
+ { transform-feedback-output transform-feedback-output initial: f read-only } ;
+
+: <render-set> ( x quot-assoc -- render-set )
+ render-set swap make-tuple ; inline
+
+: 2<render-set> ( x y quot-assoc -- render-set )
+ render-set swap 2make-tuple ; inline
+
+: 3<render-set> ( x y z quot-assoc -- render-set )
+ render-set swap 3make-tuple ; inline
+
+: render ( render-set -- )
+ {
+ [ vertex-array>> program-instance>> handle>> glUseProgram ]
+ [
+ [ vertex-array>> program-instance>> ] [ uniforms>> ] bi
+ [ bind-uniform-textures ] [ bind-uniforms ] 2bi
+ ]
+ [
+ framebuffer>>
+ [ GL_DRAW_FRAMEBUFFER swap framebuffer-handle glBindFramebuffer ]
+ [ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer GL_RASTERIZER_DISCARD glEnable ] if*
+ ]
+ [
+ [ vertex-array>> program-instance>> ]
+ [ framebuffer>> ]
+ [ output-attachments>> ] tri
+ bind-output-attachments
+ ]
+ [ vertex-array>> bind-vertex-array ]
+ [
+ dup transform-feedback-output>> [
+ [ primitive-mode>> gl-feedback-primitive-mode glBeginTransformFeedback ]
+ [ bind-transform-feedback-output ] bi*
+ ] [ drop ] if*
+ ]
+
+ [
+ [ primitive-mode>> ] [ indexes>> ] [ instances>> ] tri
+ [ render-vertex-indexes-instanced ]
+ [ render-vertex-indexes ] if*
+ ]
+
+ [ transform-feedback-output>> [ glEndTransformFeedback ] when ]
+ [ framebuffer>> [ GL_RASTERIZER_DISCARD glDisable ] unless ]
+ } 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." print ]
+ [ log>> print ] bi ;
+
+M: link-program-error error.
+ "The GLSL program " write
+ [ shader>> name>> pprint-short " failed to link." print ]
+ [ log>> print ] bi ;
+
+M: too-many-feedback-formats-error error.
+ drop
+ "Only one transform feedback format can be specified for a program." print ;
+
+M: invalid-link-feedback-format-error error.
+ drop
+ "Vertex formats used for transform feedback can't contain padding fields." print ;
+
+M: inaccurate-feedback-attribute-error error.
+ drop
+ "The types of the transform feedback attributes don't match those specified by the program's vertex format." print ;
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: alien.syntax classes gpu.buffers help.markup help.syntax
+images kernel math multiline quotations sequences 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: <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: GLSL-PROGRAM:
+{ $syntax "GLSL-PROGRAM: program-name shader shader ... shader [vertex-format] ;" }
+{ $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. A single " { $link vertex-array } " may optionally be specified; if the program is used to collect transform feedback, this format will be used for the output." }
+{ $notes "Transform feedback requires OpenGL 3.0 or one of the " { $snippet "GL_EXT_transform_feedback" } " or " { $snippet "GL_ARB_transform_feedback" } " extensions." } ;
+
+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." } ;
+
+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 } "." } ;
+
+{ 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: 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: 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: 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: 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: too-many-feedback-formats-error
+{ $class-description "This error is thrown when a " { $link POSTPONE: GLSL-PROGRAM: } " definition attempts to include more than one " { $link vertex-format } " for transform feedback formatting." } ;
+
+HELP: invalid-link-feedback-format-error
+{ $class-description "This error is thrown when the " { $link vertex-format } " specified as the transform feedback output format of a " { $link program } " is not suitable for the purpose. Transform feedback formats do not support padding (fields with a name of " { $link f } ")." } ;
+
+HELP: inaccurate-feedback-attribute-error
+{ $class-description "This error is thrown when the " { $link vertex-format } " specified as the transform feedback output format of a " { $link program } " does not match the format of the output attributes linked into a " { $link program-instance } "." } ;
+
+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." } ;
+
+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" } "." } ;
+
+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 }
+"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: } ;
+
+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 alien alien.c-types alien.strings
+alien.structs arrays assocs byte-arrays classes.mixin
+classes.parser classes.singleton combinators
+combinators.short-circuit definitions destructors
+generic.parser gpu gpu.buffers hashtables images
+io.encodings.ascii io.files io.pathnames kernel lexer literals
+locals math math.parser memoize multiline namespaces opengl
+opengl.gl opengl.shaders parser quotations sequences
+specialized-arrays.alien specialized-arrays.int splitting
+strings ui.gadgets.worlds variants vectors vocabs vocabs.loader
+vocabs.parser words words.constant ;
+IN: gpu.shaders
+
+VARIANT: shader-kind
+ vertex-shader fragment-shader ;
+
+UNION: ?string string POSTPONE: f ;
+
+ERROR: too-many-feedback-formats-error formats ;
+ERROR: invalid-link-feedback-format-error format ;
+ERROR: inaccurate-feedback-attribute-error attribute ;
+
+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 } ;
+
+MIXIN: vertex-format
+UNION: ?vertex-format vertex-format POSTPONE: f ;
+
+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 }
+ { feedback-format ?vertex-format read-only }
+ { instances hashtable read-only } ;
+
+TUPLE: shader-instance < gpu-object
+ { shader shader }
+ { world world } ;
+
+TUPLE: program-instance < gpu-object
+ { program program }
+ { world world } ;
+
+GENERIC: vertex-format-size ( format -- size )
+
+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
+
+: 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 ;
+
+: feedback-type= ( component-type dim gl-type -- ? )
+ [ 2array ] dip {
+ { $ GL_FLOAT [ { float-components 1 } ] }
+ { $ GL_FLOAT_VEC2 [ { float-components 2 } ] }
+ { $ GL_FLOAT_VEC3 [ { float-components 3 } ] }
+ { $ GL_FLOAT_VEC4 [ { float-components 4 } ] }
+ { $ GL_INT [ { int-integer-components 1 } ] }
+ { $ GL_INT_VEC2 [ { int-integer-components 2 } ] }
+ { $ GL_INT_VEC3 [ { int-integer-components 3 } ] }
+ { $ GL_INT_VEC4 [ { int-integer-components 4 } ] }
+ { $ GL_UNSIGNED_INT [ { uint-integer-components 1 } ] }
+ { $ GL_UNSIGNED_INT_VEC2 [ { uint-integer-components 2 } ] }
+ { $ GL_UNSIGNED_INT_VEC3 [ { uint-integer-components 3 } ] }
+ { $ GL_UNSIGNED_INT_VEC4 [ { uint-integer-components 4 } ] }
+ } case = ;
+
+:: assert-feedback-attribute ( size gl-type name vertex-attribute -- )
+ {
+ [ vertex-attribute name>> name = ]
+ [ size 1 = ]
+ [ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
+ } 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
+
+:: [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 ;
+
+:: [link-feedback-format] ( vertex-attributes -- quot )
+ vertex-attributes [ name>> not ] any?
+ [ [ nip invalid-link-feedback-format-error ] ] [
+ vertex-attributes
+ [ name>> ascii malloc-string ]
+ void*-array{ } map-as :> varying-names
+ vertex-attributes length :> varying-count
+ { drop varying-count varying-names GL_INTERLEAVED_ATTRIBS glTransformFeedbackVaryings }
+ >quotation
+ ] if ;
+
+:: [verify-feedback-attribute] ( vertex-attribute index -- quot )
+ vertex-attribute name>> :> name
+ name length 1 + :> name-buffer-length
+ {
+ index name-buffer-length dup
+ [ f 0 <int> 0 <int> ] dip <byte-array>
+ [ glGetTransformFeedbackVarying ] 3keep
+ ascii alien>string
+ vertex-attribute assert-feedback-attribute
+ } >quotation ;
+
+:: [verify-feedback-format] ( vertex-attributes -- quot )
+ vertex-attributes [ [verify-feedback-attribute] ] map-index :> verify-cleave
+ { drop verify-cleave cleave } >quotation ;
+
+GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- )
+
+GENERIC: link-feedback-format ( program-handle format -- )
+
+M: f link-feedback-format
+ 2drop ;
+
+GENERIC: (verify-feedback-format) ( program-instance format -- )
+
+M: f (verify-feedback-format)
+ 2drop ;
+
+: verify-feedback-format ( program-instance -- )
+ dup program>> feedback-format>> (verify-feedback-format) ;
+
+: define-vertex-format-methods ( class vertex-attributes -- )
+ {
+ [
+ [ \ bind-vertex-format create-method-in ] dip
+ [bind-vertex-format] define
+ ] [
+ [ \ link-feedback-format create-method-in ] dip
+ [link-feedback-format] define
+ ] [
+ [ \ (verify-feedback-format) create-method-in ] dip
+ [verify-feedback-format] define
+ ] [
+ [ \ vertex-format-size create-method-in ] dip
+ [ \ drop ] dip vertex-attributes-size [ ] 2sequence define
+ ]
+ } 2cleave ;
+
+: 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 ;
+
+: 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>
+
+: 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 ;
+
+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 ;
+
+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>
+
+<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 ] curry
+ [ feedback-format>> [ link-feedback-format ] curry ] bi (gl-program)
+ dup gl-program-ok? [
+ [ swap world get \ program-instance boa |dispose dup verify-feedback-format ]
+ with-destructors 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 ;
+
+: shaders-and-feedback-format ( words -- shaders feedback-format )
+ [ vertex-format? ] partition swap
+ [ [ def>> first ] map ] [
+ dup length 1 <=
+ [ [ f ] [ first ] if-empty ]
+ [ too-many-feedback-formats-error ] if
+ ] bi* ;
+
+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 shaders-and-feedback-format
+ 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 ( target 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.shaders 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" mat4-uniform f }
+ { "p_matrix" mat4-uniform f } ;
+
+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
USING: kernel accessors grouping sequences combinators
math specialized-arrays.direct.uint byte-arrays fry
specialized-arrays.direct.ushort specialized-arrays.uint
-specialized-arrays.ushort specialized-arrays.float images ;
+specialized-arrays.ushort specialized-arrays.float images
+half-floats ;
IN: images.normalization
<PRIVATE
: add-dummy-alpha ( seq -- seq' )
3 <groups> [ 255 suffix ] map concat ;
-: normalize-floats ( byte-array -- byte-array )
- byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
+: normalize-floats ( float-array -- byte-array )
+ [ 255.0 * >integer ] B{ } map-as ;
+GENERIC: normalize-component-type* ( image component-type -- image )
GENERIC: normalize-component-order* ( image component-order -- image )
: normalize-component-order ( image -- image )
+ dup component-type>> '[ _ normalize-component-type* ] change-bitmap
dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
-M: RGBA normalize-component-order* drop ;
-
-M: R32G32B32A32 normalize-component-order*
- drop normalize-floats ;
-
-M: R32G32B32 normalize-component-order*
- drop normalize-floats add-dummy-alpha ;
+M: float-components normalize-component-type*
+ drop byte-array>float-array normalize-floats ;
+M: half-components normalize-component-type*
+ drop byte-array>half-array normalize-floats ;
-: RGB16>8 ( bitmap -- bitmap' )
+: ushorts>ubytes ( bitmap -- bitmap' )
byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
-M: R16G16B16A16 normalize-component-order*
- drop RGB16>8 ;
+M: ushort-components normalize-component-type*
+ drop ushorts>ubytes ;
-M: R16G16B16 normalize-component-order*
- drop RGB16>8 add-dummy-alpha ;
+M: ubyte-components normalize-component-type*
+ drop ;
+
+M: RGBA normalize-component-order* drop ;
: BGR>RGB ( bitmap -- pixels )
3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
CONSTANT: IEXTEN OCT: 0100000
M: linux lookup-baud ( n -- n )
- dup H{
- { 0 OCT: 0000000 }
- { 50 OCT: 0000001 }
- { 75 OCT: 0000002 }
- { 110 OCT: 0000003 }
- { 134 OCT: 0000004 }
- { 150 OCT: 0000005 }
- { 200 OCT: 0000006 }
- { 300 OCT: 0000007 }
- { 600 OCT: 0000010 }
- { 1200 OCT: 0000011 }
- { 1800 OCT: 0000012 }
- { 2400 OCT: 0000013 }
- { 4800 OCT: 0000014 }
- { 9600 OCT: 0000015 }
- { 19200 OCT: 0000016 }
- { 38400 OCT: 0000017 }
+ H{
+ { 0 OCT: 0000000 }
+ { 50 OCT: 0000001 }
+ { 75 OCT: 0000002 }
+ { 110 OCT: 0000003 }
+ { 134 OCT: 0000004 }
+ { 150 OCT: 0000005 }
+ { 200 OCT: 0000006 }
+ { 300 OCT: 0000007 }
+ { 600 OCT: 0000010 }
+ { 1200 OCT: 0000011 }
+ { 1800 OCT: 0000012 }
+ { 2400 OCT: 0000013 }
+ { 4800 OCT: 0000014 }
+ { 9600 OCT: 0000015 }
+ { 19200 OCT: 0000016 }
+ { 38400 OCT: 0000017 }
{ 57600 OCT: 0010001 }
{ 115200 OCT: 0010002 }
{ 230400 OCT: 0010003 }
--- /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
sequences formatting combinators namespaces io tools.time prettyprint io.encodings.binary
accessors words mongodb.driver strings math.parser bson.writer ;
FROM: mongodb.driver => find ;
+FROM: memory => gc ;
IN: mongodb.benchmark
[ 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
: deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
[ 0 ] dip call( i -- doc ) assoc>bv
- '[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ;
+ '[ trial-size [ _ binary [ H{ } stream>assoc drop ] with-byte-reader ] times ] ;
: check-for-key ( assoc key -- )
CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ;
: [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
'[ _ swap _
'[ [ [ _ execute( -- quot ) ] dip
- [ execute( -- ) ] each _ execute( quot -- quot ) benchmark ] with-result ] each
+ [ execute( -- ) ] each _ execute( quot -- quot ) gc benchmark ] with-result ] each
print-separator ] ;
: run-serialization-bench ( doc-word-seq feat-seq -- )
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
+++ /dev/null
-Sascha Matzke
+++ /dev/null
-USING: accessors fry io io.encodings.binary io.servers.connection
-io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting
-namespaces prettyprint tools.walker calendar calendar.format bson.writer.private
-json.writer mongodb.operations.private mongodb.operations ;
-
-IN: mongodb.mmm
-
-SYMBOLS: mmm-port mmm-server-ip mmm-server-port mmm-server mmm-dump-output mmm-t-srv ;
-
-GENERIC: dump-message ( message -- )
-
-: check-options ( -- )
- mmm-port get [ 27040 mmm-port set ] unless
- mmm-server-ip get [ "127.0.0.1" mmm-server-ip set ] unless
- mmm-server-port get [ 27017 mmm-server-port set ] unless
- mmm-server-ip get mmm-server-port get <inet> mmm-server set ;
-
-: read-msg-binary ( -- )
- read-int32
- [ write-int32 ] keep
- 4 - read write ;
-
-: read-request-header ( -- msg-stub )
- mdb-msg new
- read-int32 MSG-HEADER-SIZE - >>length
- read-int32 >>req-id
- read-int32 >>resp-id
- read-int32 >>opcode ;
-
-: read-request ( -- msg-stub binary )
- binary [ read-msg-binary ] with-byte-writer
- [ binary [ read-request-header ] with-byte-reader ] keep ; ! msg-stub binary
-
-: dump-request ( msg-stub binary -- )
- [ mmm-dump-output get ] 2dip
- '[ _ drop _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ;
-
-: read-reply ( -- binary )
- binary [ read-msg-binary ] with-byte-writer ;
-
-: forward-request-read-reply ( msg-stub binary -- binary )
- [ mmm-server get binary ] 2dip
- '[ _ opcode>> _ write flush
- OP_Query =
- [ read-reply ]
- [ f ] if ] with-client ;
-
-: dump-reply ( binary -- )
- [ mmm-dump-output get ] dip
- '[ _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ;
-
-: message-prefix ( message -- prefix message )
- [ now timestamp>http-string ] dip
- [ class name>> ] keep
- [ "%s: %s" sprintf ] dip ; inline
-
-M: mdb-query-msg dump-message ( message -- )
- message-prefix
- [ collection>> ] keep
- query>> >json
- "%s -> %s: %s \n" printf ;
-
-M: mdb-insert-msg dump-message ( message -- )
- message-prefix
- [ collection>> ] keep
- objects>> >json
- "%s -> %s : %s \n" printf ;
-
-M: mdb-reply-msg dump-message ( message -- )
- message-prefix
- [ cursor>> ] keep
- [ start#>> ] keep
- [ returned#>> ] keep
- objects>> >json
- "%s -> cursor: %d, start: %d, returned#: %d, -> %s \n" printf ;
-
-M: mdb-msg dump-message ( message -- )
- message-prefix drop "%s \n" printf ;
-
-: forward-reply ( binary -- )
- write flush ;
-
-: handle-mmm-connection ( -- )
- read-request
- [ dump-request ] 2keep
- forward-request-read-reply
- [ dump-reply ] keep
- forward-reply ;
-
-: start-mmm-server ( -- )
- output-stream get mmm-dump-output set
- binary <threaded-server> [ mmm-t-srv set ] keep
- "127.0.0.1" mmm-port get <inet4> >>insecure
- [ handle-mmm-connection ] >>handler
- start-server* ;
-
-: run-mmm ( -- )
- check-options
- start-mmm-server ;
-
-MAIN: run-mmm
+++ /dev/null
-mongo-message-monitor - a small proxy to introspect messages send to MongoDB
[ opcode>> ] keep [ >>opcode ] dip
flags>> >>flags ;
-M: mdb-query-op (read-message) ( msg-stub opcode -- message )
- drop
- [ mdb-query-msg new ] dip copy-header
- read-cstring >>collection
- read-int32 >>skip#
- read-int32 >>return#
- H{ } stream>assoc change-bytes-read >>query
- dup length>> bytes-read> >
- [ H{ } stream>assoc change-bytes-read >>returnfields ] when ;
-
-M: mdb-insert-op (read-message) ( msg-stub opcode -- message )
- drop
- [ mdb-insert-msg new ] dip copy-header
- read-cstring >>collection
- V{ } clone >>objects
- [ '[ _ length>> bytes-read> > ] ] keep tuck
- '[ H{ } stream>assoc change-bytes-read _ objects>> push ]
- while ;
-
-M: mdb-delete-op (read-message) ( msg-stub opcode -- message )
- drop
- [ mdb-delete-msg new ] dip copy-header
- read-cstring >>collection
- H{ } stream>assoc change-bytes-read >>selector ;
-
-M: mdb-getmore-op (read-message) ( msg-stub opcode -- message )
- drop
- [ mdb-getmore-msg new ] dip copy-header
- read-cstring >>collection
- read-int32 >>return#
- read-longlong >>cursor ;
-
-M: mdb-killcursors-op (read-message) ( msg-stub opcode -- message )
- drop
- [ mdb-killcursors-msg new ] dip copy-header
- read-int32 >>cursors#
- V{ } clone >>cursors
- [ [ cursors#>> ] keep
- '[ read-longlong _ cursors>> push ] times ] keep ;
-
-M: mdb-update-op (read-message) ( msg-stub opcode -- message )
- drop
- [ mdb-update-msg new ] dip copy-header
- read-cstring >>collection
- read-int32 >>upsert?
- H{ } stream>assoc change-bytes-read >>selector
- H{ } stream>assoc change-bytes-read >>object ;
-
M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
drop
[ <mdb-reply-msg> ] dip copy-header
read-longlong >>cursor
read-int32 >>start#
read-int32 [ >>returned# ] keep
- [ H{ } stream>assoc drop ] accumulator [ times ] dip >>objects ;
+ [ H{ } stream>assoc ] accumulator [ times ] dip >>objects ;
: read-header ( message -- message )
read-int32 >>length
: 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 ;
image new
swap >>dim
swap >>bitmap
- L >>component-order ;
+ L >>component-order
+ ubyte-components >>component-type ;
:: perlin-noise-unsafe ( table point -- value )
point unit-cube :> cube
--- /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
: (make-reflection-depthbuffer) ( -- depthbuffer )
gen-renderbuffer [
- GL_RENDERBUFFER_EXT swap glBindRenderbufferEXT
- GL_RENDERBUFFER_EXT GL_DEPTH_COMPONENT32 (reflection-dim) glRenderbufferStorageEXT
+ GL_RENDERBUFFER swap glBindRenderbuffer
+ GL_RENDERBUFFER GL_DEPTH_COMPONENT32 (reflection-dim) glRenderbufferStorage
] keep ;
: (make-reflection-framebuffer) ( depthbuffer -- framebuffer )
gen-framebuffer dup [
- swap [ GL_FRAMEBUFFER_EXT GL_DEPTH_ATTACHMENT_EXT GL_RENDERBUFFER_EXT ] dip
- glFramebufferRenderbufferEXT
+ swap [ GL_DRAW_FRAMEBUFFER GL_DEPTH_ATTACHMENT GL_RENDERBUFFER ] dip
+ glFramebufferRenderbuffer
] with-framebuffer ;
: (plane-program) ( -- program )
: (reflection-face) ( gadget face -- )
swap reflection-texture>> [
- GL_FRAMEBUFFER_EXT
- GL_COLOR_ATTACHMENT0_EXT
- ] 2dip 0 glFramebufferTexture2DEXT
+ GL_DRAW_FRAMEBUFFER
+ GL_COLOR_ATTACHMENT0
+ ] 2dip 0 glFramebufferTexture2D
check-framebuffer ;
: (draw-reflection-texture) ( gadget -- )
<image>
swap >>bitmap
RGBA >>component-order
+ ubyte-components >>component-type
terrain-segment-size >>dim ;
: terrain-segment ( terrain at -- image )
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+\\)\\( .*\\)?$")
("\\_<\\(}\\)\\_>" (1 "){"))
;; Parenthesis:
("\\_<\\((\\)\\_>" (1 "()"))
- ("\\_<call\\((\\)\\_>" (1 "()"))
+ ("\\_<\\w*\\((\\)\\_>" (1 "()"))
("\\_<\\()\\)\\_>" (1 ")("))
("\\_<(\\((\\)\\_>" (1 "()"))
("\\_<\\()\\))\\_>" (1 ")("))
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