steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into dcn

db4
Slava Pestov 2009-07-28 11:20:43 -05:00
parent 5344302040 037fa69a21
commit 4175585fd4
16 changed files with 836 additions and 326 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
basis/byte-arrays/hex/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

6
basis/byte-arrays/hex/hex-docs.factor Normal file
View File

@ -0,0 +1,6 @@
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." } ;

11
basis/byte-arrays/hex/hex.factor Normal file
View File

@ -0,0 +1,11 @@
! Copyright (C) 2009 Joe Groff.
! 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 ;

53
basis/cpu/x86/assembler/assembler-tests.factor
View File

@ -8,6 +8,32 @@ IN: cpu.x86.assembler.tests
[ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test [ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX 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
! 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: 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: 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: 4c HEX: 0f HEX: 2c HEX: e0 } ] [ [ R12 XMM0 CVTTSD2SI ] { } make ] unit-test
@ -25,6 +51,32 @@ IN: cpu.x86.assembler.tests
! [ { HEX: f2 HEX: 0f HEX: 11 HEX: 00 } ] [ [ RAX [] XMM0 MOVSD ] { } 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 ! [ { 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
[ { HEX: 66 HEX: 0f HEX: c4 HEX: c1 HEX: 02 } ] [ [ XMM0 ECX 2 PINSRW ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: c5 HEX: c1 HEX: 02 } ] [ [ EAX XMM1 2 PEXTRW ] { } 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
! memory address modes
[ { HEX: 8a HEX: 18 } ] [ [ BL RAX [] MOV ] { } make ] unit-test [ { HEX: 8a HEX: 18 } ] [ [ BL RAX [] MOV ] { } make ] unit-test
[ { HEX: 66 HEX: 8b HEX: 18 } ] [ [ BX 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: 8b HEX: 18 } ] [ [ EBX RAX [] MOV ] { } make ] unit-test
@ -72,3 +124,4 @@ IN: cpu.x86.assembler.tests
[ { HEX: 48 HEX: 69 HEX: c1 HEX: 44 HEX: 03 HEX: 00 HEX: 00 } ] [ [ RAX RCX HEX: 344 IMUL3 ] { } 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 [ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test

265
basis/cpu/x86/assembler/assembler.factor
View File

@ -3,6 +3,7 @@
USING: arrays io.binary kernel combinators kernel.private math USING: arrays io.binary kernel combinators kernel.private math
namespaces make sequences words system layouts math.order accessors namespaces make sequences words system layouts math.order accessors
cpu.x86.assembler.syntax ; cpu.x86.assembler.syntax ;
QUALIFIED: sequences
IN: cpu.x86.assembler IN: cpu.x86.assembler
! A postfix assembler for x86-32 and x86-64. ! A postfix assembler for x86-32 and x86-64.
@ -12,11 +13,16 @@ IN: cpu.x86.assembler
! Beware! ! Beware!
! Register operands -- eg, ECX ! 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 REGISTERS: 64
RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ; RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
@ -214,6 +220,8 @@ M: object operand-64? drop f ;
: extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ; : extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ;
: ssse3-opcode ( opcode -- opcode' ) OCT: 17 sequences:prefix ;
: extended-opcode, ( opcode -- ) extended-opcode opcode, ; : extended-opcode, ( opcode -- ) extended-opcode opcode, ;
: opcode-or ( opcode mask -- opcode' ) : opcode-or ( opcode mask -- opcode' )
@ -451,6 +459,9 @@ M: operand TEST OCT: 204 2-operand ;
! Misc ! Misc
: NOP ( -- ) HEX: 90 , ; : NOP ( -- ) HEX: 90 , ;
: PAUSE ( -- ) HEX: f3 , HEX: 90 , ;
: RDPMC ( -- ) HEX: 0f , HEX: 33 , ;
! x87 Floating Point Unit ! x87 Floating Point Unit
@ -468,26 +479,242 @@ M: operand TEST OCT: 204 2-operand ;
pick register-128? [ swapd ] [ BIN: 1 bitor ] if ; pick register-128? [ swapd ] [ BIN: 1 bitor ] if ;
: 2-operand-sse ( dst src op1 op2 -- ) : 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-ssse3 ( dst src op1 op2 -- )
[ , ] when* swapd ssse3-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 -- ) : 2-operand-int/sse ( dst src op1 op2 -- )
, swapd extended-opcode (2-operand) ; [ , ] when* swapd extended-opcode (2-operand) ;
: 3-operand-sse ( dst src imm op1 op2 -- )
rot [ 2-operand-rm-sse ] dip , ;
: 2-operand-sse-cmp ( dst src cmp op1 op2 -- )
3-operand-sse ; inline
: 2-operand-sse-shift ( dst imm reg op1 op2 -- )
[ , ] when*
[ f HEX: 0f ] dip 2array 3array
swapd 1-operand , ;
PRIVATE> PRIVATE>
: MOVSS ( dest src -- ) HEX: 10 HEX: f3 2-operand-sse ; : MOVUPS ( dest src -- ) HEX: 10 f 2-operand-sse ;
: MOVSD ( dest src -- ) HEX: 10 HEX: f2 2-operand-sse ; : MOVUPD ( dest src -- ) HEX: 10 HEX: 66 2-operand-sse ;
: ADDSD ( dest src -- ) HEX: 58 HEX: f2 2-operand-sse ; : MOVSD ( dest src -- ) HEX: 10 HEX: f2 2-operand-sse ;
: MULSD ( dest src -- ) HEX: 59 HEX: f2 2-operand-sse ; : MOVSS ( dest src -- ) HEX: 10 HEX: f3 2-operand-sse ;
: SUBSD ( dest src -- ) HEX: 5c HEX: f2 2-operand-sse ; : MOVLPS ( dest src -- ) HEX: 12 f 2-operand-sse ;
: DIVSD ( dest src -- ) HEX: 5e HEX: f2 2-operand-sse ; : MOVLPD ( dest src -- ) HEX: 12 HEX: 66 2-operand-sse ;
: SQRTSD ( dest src -- ) HEX: 51 HEX: f2 2-operand-sse ; : MOVDDUP ( dest src -- ) HEX: 12 HEX: f2 2-operand-rm-sse ;
: UCOMISD ( dest src -- ) HEX: 2e HEX: 66 2-operand-sse ; : MOVSLDUP ( dest src -- ) HEX: 12 HEX: f3 2-operand-rm-sse ;
: COMISD ( dest src -- ) HEX: 2f HEX: 66 2-operand-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 ;
: CVTSS2SD ( dest src -- ) HEX: 5a HEX: f3 2-operand-sse ; : PREFETCHNTA ( mem -- ) { BIN: 000 f { HEX: 0f HEX: 18 } } 1-operand ;
: CVTSD2SS ( dest src -- ) HEX: 5a HEX: f2 2-operand-sse ; : 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-ssse3 ;
: PHADDW ( dest src -- ) { HEX: 38 HEX: 01 } HEX: 66 2-operand-ssse3 ;
: PHADDD ( dest src -- ) { HEX: 38 HEX: 02 } HEX: 66 2-operand-ssse3 ;
: PHADDSW ( dest src -- ) { HEX: 38 HEX: 03 } HEX: 66 2-operand-ssse3 ;
: PMADDUBSW ( dest src -- ) { HEX: 38 HEX: 04 } HEX: 66 2-operand-ssse3 ;
: PHSUBW ( dest src -- ) { HEX: 38 HEX: 05 } HEX: 66 2-operand-ssse3 ;
: PHSUBD ( dest src -- ) { HEX: 38 HEX: 06 } HEX: 66 2-operand-ssse3 ;
: PHSUBSW ( dest src -- ) { HEX: 38 HEX: 07 } HEX: 66 2-operand-ssse3 ;
: PSIGNB ( dest src -- ) { HEX: 38 HEX: 08 } HEX: 66 2-operand-ssse3 ;
: PSIGNW ( dest src -- ) { HEX: 38 HEX: 09 } HEX: 66 2-operand-ssse3 ;
: PSIGND ( dest src -- ) { HEX: 38 HEX: 0A } HEX: 66 2-operand-ssse3 ;
: PMULHRSW ( dest src -- ) { HEX: 38 HEX: 0B } HEX: 66 2-operand-ssse3 ;
: PABSB ( dest src -- ) { HEX: 38 HEX: 1C } HEX: 66 2-operand-ssse3 ;
: PABSW ( dest src -- ) { HEX: 38 HEX: 1D } HEX: 66 2-operand-ssse3 ;
: PABSD ( dest src -- ) { HEX: 38 HEX: 1E } HEX: 66 2-operand-ssse3 ;
: PALIGNR ( dest src -- ) { HEX: 3A HEX: 0F } HEX: 66 2-operand-ssse3 ;
: 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-sse ;
: PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-sse ;
: PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-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 , ;
: 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-sse ;
: PEXTRW ( dest src imm -- ) HEX: c5 HEX: 66 3-operand-sse ;
: SHUFPS ( dest src imm -- ) HEX: c6 f 3-operand-sse ;
: SHUFPD ( dest src imm -- ) HEX: c6 HEX: 66 3-operand-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
: 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 ;

18
basis/opengl/shaders/shaders.factor
View File

@ -61,22 +61,18 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
! Programs ! Programs
: <mrt-gl-program> ( shaders frag-data-locations -- program ) : (gl-program) ( shaders quot: ( gl-program -- ) -- program )
glCreateProgram glCreateProgram
[ [
[ swap [ glAttachShader ] with each ] [ swap [ glAttachShader ] with each ]
[ swap [ first2 swap glBindFragDataLocation ] with each ] bi-curry bi* [ swap call ] bi-curry bi*
] ] [ glLinkProgram ] [ ] tri gl-error ; inline
[ glLinkProgram ]
[ ] tri : <mrt-gl-program> ( shaders frag-data-locations -- program )
gl-error ; [ [ first2 swap glBindFragDataLocation ] with each ] curry (gl-program) ;
: <gl-program> ( shaders -- program ) : <gl-program> ( shaders -- program )
glCreateProgram [ drop ] (gl-program) ;
[ swap [ glAttachShader ] with each ]
[ glLinkProgram ]
[ ] tri
gl-error ;
: (gl-program?) ( object -- ? ) : (gl-program?) ( object -- ? )
dup integer? [ glIsProgram c-bool> ] [ drop f ] if ; dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;

12
basis/tools/disassembler/disassembler.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: tr arrays sequences io words generic system combinators USING: alien alien.c-types arrays byte-arrays combinators
vocabs.loader kernel ; destructors generic io kernel libc math sequences system tr
vocabs.loader words ;
IN: tools.disassembler IN: tools.disassembler
GENERIC: disassemble ( obj -- ) GENERIC: disassemble ( obj -- )
@ -12,6 +13,13 @@ HOOK: disassemble* disassembler-backend ( from to -- lines )
TR: tabs>spaces "\t" "\s" ; 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: pair disassemble first2 disassemble* [ tabs>spaces print ] each ;
M: word disassemble word-xt 2array disassemble ; M: word disassemble word-xt 2array disassemble ;

41
extra/gpu/buffers/buffers-docs.factor
View File

@ -10,6 +10,13 @@ HELP: <buffer-ptr>
} }
{ $description "Constructs a " { $link buffer-ptr } " tuple." } ; { $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> HELP: <buffer>
{ $values { $values
{ "upload" buffer-upload-pattern } { "upload" buffer-upload-pattern }
@ -52,6 +59,7 @@ HELP: buffer-kind
{ "An " { $link index-buffer } " is used to store indexes into 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-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 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." } ; { $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." } ;
@ -62,6 +70,30 @@ HELP: buffer-ptr
{ { $snippet "offset" } " is an integer offset from the beginning of the buffer." } { { $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 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." { $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 { $list
@ -148,6 +180,10 @@ HELP: stream-upload
{ dynamic-upload static-upload stream-upload } related-words { 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 HELP: update-buffer
{ $values { $values
{ "buffer-ptr" buffer-ptr } { "size" integer } { "data" { $maybe c-ptr } } { "buffer-ptr" buffer-ptr } { "size" integer } { "data" { $maybe c-ptr } }
@ -157,7 +193,7 @@ HELP: update-buffer
HELP: vertex-buffer 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." } ; { $class-description "This " { $link buffer-kind } " declares that a " { $link buffer } "'s primary use will be to provide vertex attribute information to a vertex array." } ;
{ index-buffer pixel-pack-buffer pixel-unpack-buffer vertex-buffer } related-words { index-buffer pixel-pack-buffer pixel-unpack-buffer vertex-buffer transform-feedback-buffer } related-words
HELP: with-mapped-buffer HELP: with-mapped-buffer
{ $values { $values
@ -165,7 +201,7 @@ HELP: with-mapped-buffer
} }
{ $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." } ; { $description "Maps " { $snippet "buffer" } " into CPU address space with " { $snippet "access" } " for the dynamic extent of " { $snippet "quot" } ". " { $snippet "quot" } " is called with a pointer to the mapped memory on top of the stack." } ;
{ allocate-buffer update-buffer read-buffer copy-buffer with-mapped-buffer } related-words { allocate-buffer buffer-size update-buffer read-buffer copy-buffer with-mapped-buffer } related-words
HELP: write-access 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 } "." } ; { $class-description "This " { $link buffer-access-mode } " value requests write-only access when mapping a buffer object through " { $link with-mapped-buffer } "." } ;
@ -183,6 +219,7 @@ ARTICLE: "gpu.buffers" "Buffer objects"
{ $subsection buffer-usage-pattern } { $subsection buffer-usage-pattern }
"Referencing buffer data:" "Referencing buffer data:"
{ $subsection buffer-ptr } { $subsection buffer-ptr }
{ $subsection buffer-range }
"Manipulating buffer data:" "Manipulating buffer data:"
{ $subsection allocate-buffer } { $subsection allocate-buffer }
{ $subsection update-buffer } { $subsection update-buffer }

35
extra/gpu/buffers/buffers.factor
View File

@ -15,7 +15,8 @@ VARIANT: buffer-access-mode
VARIANT: buffer-kind VARIANT: buffer-kind
vertex-buffer index-buffer vertex-buffer index-buffer
pixel-unpack-buffer pixel-pack-buffer ; pixel-unpack-buffer pixel-pack-buffer
transform-feedback-buffer ;
TUPLE: buffer < gpu-object TUPLE: buffer < gpu-object
{ upload-pattern buffer-upload-pattern } { upload-pattern buffer-upload-pattern }
@ -52,8 +53,15 @@ TUPLE: buffer < gpu-object
{ index-buffer [ GL_ELEMENT_ARRAY_BUFFER ] } { index-buffer [ GL_ELEMENT_ARRAY_BUFFER ] }
{ pixel-unpack-buffer [ GL_PIXEL_UNPACK_BUFFER ] } { pixel-unpack-buffer [ GL_PIXEL_UNPACK_BUFFER ] }
{ pixel-pack-buffer [ GL_PIXEL_PACK_BUFFER ] } { pixel-pack-buffer [ GL_PIXEL_PACK_BUFFER ] }
{ transform-feedback-buffer [ GL_TRANSFORM_FEEDBACK_BUFFER ] }
} case ; inline } 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> PRIVATE>
M: buffer dispose M: buffer dispose
@ -64,11 +72,22 @@ TUPLE: buffer-ptr
{ offset integer read-only } ; { offset integer read-only } ;
C: <buffer-ptr> buffer-ptr 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 ; 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 -- ) :: allocate-buffer ( buffer size initial-data -- )
buffer kind>> gl-target :> target buffer bind-buffer :> target
target buffer handle>> glBindBuffer
target size initial-data buffer gl-buffer-usage glBufferData ; target size initial-data buffer gl-buffer-usage glBufferData ;
: <buffer> ( upload usage kind size initial-data -- buffer ) : <buffer> ( upload usage kind size initial-data -- buffer )
@ -81,15 +100,13 @@ UNION: gpu-data-ptr buffer-ptr c-ptr ;
:: update-buffer ( buffer-ptr size data -- ) :: update-buffer ( buffer-ptr size data -- )
buffer-ptr buffer>> :> buffer buffer-ptr buffer>> :> buffer
buffer kind>> gl-target :> target buffer bind-buffer :> target
target buffer handle>> glBindBuffer
target buffer-ptr offset>> size data glBufferSubData ; target buffer-ptr offset>> size data glBufferSubData ;
:: read-buffer ( buffer-ptr size -- data ) :: read-buffer ( buffer-ptr size -- data )
buffer-ptr buffer>> :> buffer buffer-ptr buffer>> :> buffer
buffer kind>> gl-target :> target buffer bind-buffer :> target
size <byte-array> :> data size <byte-array> :> data
target buffer handle>> glBindBuffer
target buffer-ptr offset>> size data glGetBufferSubData target buffer-ptr offset>> size data glGetBufferSubData
data ; data ;
@ -102,9 +119,7 @@ UNION: gpu-data-ptr buffer-ptr c-ptr ;
size glCopyBufferSubData ; size glCopyBufferSubData ;
:: with-mapped-buffer ( buffer access quot: ( alien -- ) -- ) :: with-mapped-buffer ( buffer access quot: ( alien -- ) -- )
buffer kind>> gl-target :> target buffer bind-buffer :> target
target buffer handle>> glBindBuffer
target access gl-access glMapBuffer target access gl-access glMapBuffer
quot call quot call

76
extra/gpu/render/render-docs.factor
View File

@ -34,13 +34,6 @@ HELP: <multi-index-range>
} }
{ $description "Constructs a " { $link multi-index-range } " tuple." } ; { $description "Constructs a " { $link multi-index-range } " tuple." } ;
HELP: <vertex-array>
{ $values
{ "program-instance" program-instance } { "vertex-formats" "a list of " { $link buffer-ptr } "/" { $link vertex-format } " pairs" }
{ "vertex-array" vertex-array }
}
{ $description "Creates a new " { $link vertex-array } " to feed data to " { $snippet "program-instance" } " from the set of " { $link buffer } "s specified in " { $snippet "vertex-formats" } "." } ;
HELP: UNIFORM-TUPLE: HELP: UNIFORM-TUPLE:
{ $syntax <" UNIFORM-TUPLE: class-name { $syntax <" UNIFORM-TUPLE: class-name
{ "slot" uniform-type dimension } { "slot" uniform-type dimension }
@ -78,30 +71,9 @@ $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." "A value of a uniform tuple type is a standard Factor tuple. Uniform tuples are constructed with " { $link new } " or " { $link boa } ", and values are placed inside them using standard slot accessors."
} ; } ;
HELP: VERTEX-FORMAT:
{ $syntax <" VERTEX-FORMAT: format-name
{ "attribute"/f component-type dimension normalize? }
{ "attribute"/f component-type dimension normalize? }
...
{ "attribute"/f component-type dimension normalize? } ; "> }
{ $description "Defines a new binary " { $link vertex-format } " for structuring vertex data stored in " { $link buffer } "s. Each " { $snippet "attribute" } " name either corresponds to an input parameter of a vertex shader, or is " { $link f } " to include padding in the vertex format. The " { $link component-type } " determines the format of the components, and the " { $snippet "dimension" } " determines the number of components. If the " { $snippet "component-type" } " is an integer type and " { $snippet "normalize?" } " is true, the component values will be scaled to the range 0.0 to 1.0 when fed to the vertex shader; otherwise, they will be cast to floats retaining their integral values." } ;
HELP: VERTEX-STRUCT:
{ $syntax <" VERTEX-STRUCT: struct-name format-name "> }
{ $description "Defines a struct C type (like " { $link POSTPONE: C-STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ;
HELP: bool-uniform HELP: bool-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a boolean uniform parameter." } ; { $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a boolean uniform parameter." } ;
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: bvec2-uniform 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." } ; { $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a two-component boolean vector uniform parameter." } ;
@ -117,18 +89,6 @@ HELP: define-uniform-tuple
} }
{ $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." } ; { $description "Defines a new " { $link uniform-tuple } " as a subclass of " { $snippet "superclass" } " with the slots specified by the " { $link uniform } " tuple values in " { $snippet "uniforms" } ". The runtime equivalent of " { $link POSTPONE: UNIFORM-TUPLE: } ". This word must be called inside a compilation unit." } ;
HELP: define-vertex-format
{ $values
{ "class" class } { "vertex-attributes" sequence }
}
{ $description "Defines a new " { $link vertex-format } " with the binary format specified by the " { $link vertex-attribute } " tuple values in " { $snippet "vertex-attributes" } ". The runtime equivalent of " { $link POSTPONE: VERTEX-FORMAT: } ". This word must be called inside a compilation unit." } ;
HELP: define-vertex-struct
{ $values
{ "struct-name" string } { "vertex-format" vertex-format }
}
{ $description "Defines a new struct C type from a " { $link vertex-format } ". The runtime equivalent of " { $link POSTPONE: VERTEX-STRUCT: } ". This word must be called inside a compilation unit." } ;
HELP: float-uniform HELP: float-uniform
{ $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a float uniform parameter." } ; { $class-description "This " { $link uniform-type } " indicates that a slot of a " { $link uniform-tuple } " corresponds to a float uniform parameter." } ;
@ -254,9 +214,11 @@ HELP: render-set
{ "The " { $snippet "uniforms" } " slot contains a " { $link uniform-tuple } " with values for the shader program's uniform parameters." } { "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 "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 "instances" } " slot, if not " { $link f } ", instructs the GPU to render several instances of the same set of vertexes. Instancing requires OpenGL 3.1 or one of the " { $snippet "GL_EXT_draw_instanced" } " or " { $snippet "GL_ARB_draw_instanced" } " extensions." }
{ "The " { $snippet "framebuffer" } " slot determines the target for the rendering output. Either the " { $link system-framebuffer } " or a user-created " { $link framebuffer } " object can be specified. User-created framebuffers require OpenGL 3.0 or one of the " { $snippet "GL_EXT_framebuffer_object" } " or " { $snippet "GL_ARB_framebuffer_object" } " extensions." } { "The " { $snippet "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. Named output values are available in GLSL 1.30 or later, and GLSL 1.20 and earlier using the " { $snippet "GL_EXT_gpu_shader4" } " extension." } { "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 { render render-set } related-words
@ -313,29 +275,6 @@ HELP: vec3-uniform
HELP: vec4-uniform 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." } ; { $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-array
{ $class-description "A " { $snippet "vertex-array" } " object associates a shader " { $link program-instance } " with vertex attribute data from one or more " { $link buffer } "s. The format of the binary data inside these buffers is described using " { $link vertex-format } "s. " { $snippet "vertex-array" } "s are constructed using the " { $link <vertex-array> } " or " { $link buffer>vertex-array } " words." } ;
HELP: vertex-array-buffer
{ $values
{ "vertex-array" vertex-array }
{ "vertex-buffer" buffer }
}
{ $description "Returns the first " { $link buffer } " object comprised in " { $snippet "vertex-array" } "." } ;
HELP: vertex-attribute
{ $class-description "This tuple type is passed to " { $link define-vertex-format } " to define a new " { $link vertex-format } " type." } ;
HELP: vertex-format
{ $class-description "This class encompasses all vertex formats defined by " { $link POSTPONE: VERTEX-FORMAT: } ". A vertex format defines the binary layout of vertex attribute data in a " { $link buffer } " for use as part of a " { $link vertex-array } ". See the " { $link POSTPONE: VERTEX-FORMAT: } " documentation for details on how vertex formats are defined." } ;
HELP: vertex-format-size
{ $values
{ "format" vertex-format }
{ "size" integer }
}
{ $description "Returns the size in bytes of a set of vertex attributes in " { $snippet "format" } "." } ;
HELP: vertex-indexes 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." { $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 { $list
@ -349,11 +288,6 @@ ARTICLE: "gpu.render" "Rendering"
"The " { $vocab-link "gpu.render" } " vocabulary contains words for organizing and submitting data to the GPU for rendering." "The " { $vocab-link "gpu.render" } " vocabulary contains words for organizing and submitting data to the GPU for rendering."
{ $subsection render } { $subsection render }
{ $subsection render-set } { $subsection render-set }
"Render data inside GPU " { $link buffer } "s is organized into " { $link vertex-array } "s for consumption by shader code:"
{ $subsection vertex-array }
{ $subsection <vertex-array> }
{ $subsection buffer>vertex-array }
{ $subsection POSTPONE: VERTEX-FORMAT: }
{ $link uniform-tuple } "s provide Factor types for containing and submitting shader uniform parameters:" { $link uniform-tuple } "s provide Factor types for containing and submitting shader uniform parameters:"
{ $subsection POSTPONE: UNIFORM-TUPLE: } { $subsection POSTPONE: UNIFORM-TUPLE: }
; ;

230
extra/gpu/render/render.factor
View File

@ -3,24 +3,17 @@ USING: accessors alien alien.c-types alien.structs arrays
assocs classes classes.mixin classes.parser classes.singleton assocs classes classes.mixin classes.parser classes.singleton
classes.tuple classes.tuple.private combinators combinators.tuple destructors fry classes.tuple classes.tuple.private combinators combinators.tuple destructors fry
generic generic.parser gpu gpu.buffers gpu.framebuffers generic generic.parser gpu gpu.buffers gpu.framebuffers
gpu.framebuffers.private gpu.shaders gpu.state gpu.textures gpu.framebuffers.private gpu.shaders gpu.shaders.private gpu.state
gpu.textures.private half-floats images kernel lexer locals gpu.textures gpu.textures.private half-floats images kernel
math math.order math.parser namespaces opengl opengl.gl parser lexer locals math math.order math.parser namespaces opengl
quotations sequences slots sorting specialized-arrays.alien opengl.gl parser quotations sequences slots sorting
specialized-arrays.float specialized-arrays.int specialized-arrays.alien specialized-arrays.float specialized-arrays.int
specialized-arrays.uint strings tr ui.gadgets.worlds variants specialized-arrays.uint strings tr ui.gadgets.worlds variants
vocabs.parser words ; vocabs.parser words ;
IN: gpu.render IN: gpu.render
UNION: ?string string POSTPONE: f ;
UNION: ?integer integer POSTPONE: f ; UNION: ?integer integer POSTPONE: f ;
TUPLE: vertex-attribute
{ name ?string read-only initial: f }
{ component-type component-type read-only initial: float-components }
{ dim integer read-only initial: 4 }
{ normalize? boolean read-only initial: f } ;
VARIANT: uniform-type VARIANT: uniform-type
bool-uniform bool-uniform
bvec2-uniform bvec2-uniform
@ -111,52 +104,12 @@ VARIANT: primitive-mode
triangle-strip-mode triangle-strip-mode
triangle-fan-mode ; triangle-fan-mode ;
MIXIN: vertex-format
TUPLE: uniform-tuple ; TUPLE: uniform-tuple ;
GENERIC: vertex-format-size ( format -- size )
ERROR: invalid-uniform-type uniform ; ERROR: invalid-uniform-type uniform ;
<PRIVATE <PRIVATE
: gl-vertex-type ( component-type -- gl-type )
{
{ ubyte-components [ GL_UNSIGNED_BYTE ] }
{ ushort-components [ GL_UNSIGNED_SHORT ] }
{ uint-components [ GL_UNSIGNED_INT ] }
{ half-components [ GL_HALF_FLOAT ] }
{ float-components [ GL_FLOAT ] }
{ byte-integer-components [ GL_BYTE ] }
{ short-integer-components [ GL_SHORT ] }
{ int-integer-components [ GL_INT ] }
{ ubyte-integer-components [ GL_UNSIGNED_BYTE ] }
{ ushort-integer-components [ GL_UNSIGNED_SHORT ] }
{ uint-integer-components [ GL_UNSIGNED_INT ] }
} case ;
: vertex-type-size ( component-type -- size )
{
{ ubyte-components [ 1 ] }
{ ushort-components [ 2 ] }
{ uint-components [ 4 ] }
{ half-components [ 2 ] }
{ float-components [ 4 ] }
{ byte-integer-components [ 1 ] }
{ short-integer-components [ 2 ] }
{ int-integer-components [ 4 ] }
{ ubyte-integer-components [ 1 ] }
{ ushort-integer-components [ 2 ] }
{ uint-integer-components [ 4 ] }
} case ;
: vertex-attribute-size ( vertex-attribute -- size )
[ component-type>> vertex-type-size ] [ dim>> ] bi * ;
: vertex-attributes-size ( vertex-attributes -- size )
[ vertex-attribute-size ] [ + ] map-reduce ;
: gl-index-type ( index-type -- gl-index-type ) : gl-index-type ( index-type -- gl-index-type )
{ {
{ ubyte-indexes [ GL_UNSIGNED_BYTE ] } { ubyte-indexes [ GL_UNSIGNED_BYTE ] }
@ -210,56 +163,6 @@ M: multi-index-elements render-vertex-indexes
: (bind-texture-unit) ( texture texture-unit -- ) : (bind-texture-unit) ( texture texture-unit -- )
swap [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline swap [ GL_TEXTURE0 + glActiveTexture ] [ bind-texture drop ] bi* ; inline
:: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
vertex-attribute name>> :> name
vertex-attribute component-type>> :> type
type gl-vertex-type :> gl-type
vertex-attribute dim>> :> dim
vertex-attribute normalize?>> >c-bool :> normalize?
vertex-attribute vertex-attribute-size :> size
stride offset size +
{
{ [ name not ] [ [ 2drop ] ] }
{
[ type unnormalized-integer-components? ]
[
{
name attribute-index [ glEnableVertexAttribArray ] keep
dim gl-type stride offset
} >quotation :> dip-block
{ dip-block dip <displaced-alien> glVertexAttribIPointer } >quotation
]
}
[
{
name attribute-index [ glEnableVertexAttribArray ] keep
dim gl-type normalize? stride offset
} >quotation :> dip-block
{ dip-block dip <displaced-alien> glVertexAttribPointer } >quotation
]
} cond ;
:: [bind-vertex-format] ( vertex-attributes -- quot )
vertex-attributes vertex-attributes-size :> stride
stride 0 vertex-attributes [ [bind-vertex-attribute] ] { } map-as 2nip :> attributes-cleave
{ attributes-cleave 2cleave } >quotation :> with-block
{ drop vertex-buffer with-block with-buffer-ptr } >quotation ;
GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- )
: define-vertex-format-methods ( class vertex-attributes -- )
[
[ \ bind-vertex-format create-method-in ] dip
[bind-vertex-format] define
] [
[ \ vertex-format-size create-method-in ] dip
[ \ drop ] dip vertex-attributes-size [ ] 2sequence define
] 2bi ;
GENERIC: bind-uniform-textures ( program-instance uniform-tuple -- ) GENERIC: bind-uniform-textures ( program-instance uniform-tuple -- )
GENERIC: bind-uniforms ( program-instance uniform-tuple -- ) GENERIC: bind-uniforms ( program-instance uniform-tuple -- )
@ -483,39 +386,6 @@ TR: hyphens>underscores "-" "_" ;
] } ] }
} case ; } case ;
: component-type>c-type ( component-type -- c-type )
{
{ ubyte-components [ "uchar" ] }
{ ushort-components [ "ushort" ] }
{ uint-components [ "uint" ] }
{ half-components [ "half" ] }
{ float-components [ "float" ] }
{ byte-integer-components [ "char" ] }
{ ubyte-integer-components [ "uchar" ] }
{ short-integer-components [ "short" ] }
{ ushort-integer-components [ "ushort" ] }
{ int-integer-components [ "int" ] }
{ uint-integer-components [ "uint" ] }
} case ;
: c-array-dim ( dim -- string )
dup 1 = [ drop "" ] [ number>string "[" "]" surround ] if ;
SYMBOL: padding-no
padding-no [ 0 ] initialize
: padding-name ( -- name )
"padding-"
padding-no get number>string append
"(" ")" surround
padding-no inc ;
: vertex-attribute>c-type ( vertex-attribute -- {type,name} )
[
[ component-type>> component-type>c-type ]
[ dim>> c-array-dim ] bi append
] [ name>> [ padding-name ] unless* ] bi 2array ;
: (define-uniform-tuple) ( class superclass uniforms -- ) : (define-uniform-tuple) ( class superclass uniforms -- )
{ {
[ [ uniform>slot ] map define-tuple-class ] [ [ uniform>slot ] map define-tuple-class ]
@ -536,55 +406,12 @@ padding-no [ 0 ] initialize
PRIVATE> PRIVATE>
: define-vertex-format ( class vertex-attributes -- )
[
[
[ define-singleton-class ]
[ vertex-format add-mixin-instance ]
[ ] tri
] [ define-vertex-format-methods ] bi*
]
[ "vertex-format-attributes" set-word-prop ] 2bi ;
SYNTAX: VERTEX-FORMAT:
CREATE-CLASS parse-definition
[ first4 vertex-attribute boa ] map
define-vertex-format ;
: define-vertex-struct ( struct-name vertex-format -- )
[ current-vocab ] dip
"vertex-format-attributes" word-prop [ vertex-attribute>c-type ] map
define-struct ;
SYNTAX: VERTEX-STRUCT:
scan scan-word define-vertex-struct ;
: define-uniform-tuple ( class superclass uniforms -- ) : define-uniform-tuple ( class superclass uniforms -- )
(define-uniform-tuple) ; inline (define-uniform-tuple) ; inline
SYNTAX: UNIFORM-TUPLE: SYNTAX: UNIFORM-TUPLE:
parse-uniform-tuple-definition define-uniform-tuple ; parse-uniform-tuple-definition define-uniform-tuple ;
TUPLE: vertex-array < gpu-object
{ program-instance program-instance read-only }
{ vertex-buffers sequence read-only } ;
M: vertex-array dispose
[ [ delete-vertex-array ] when* f ] change-handle drop ;
: <vertex-array> ( program-instance vertex-formats -- vertex-array )
gen-vertex-array
[ glBindVertexArray [ first2 bind-vertex-format ] with each ]
[ -rot [ first buffer>> ] map vertex-array boa ] 3bi
window-resource ;
: buffer>vertex-array ( vertex-buffer program-instance format -- vertex-array )
[ swap ] dip
[ 0 <buffer-ptr> ] dip 2array 1array <vertex-array> ; inline
: vertex-array-buffer ( vertex-array -- vertex-buffer )
vertex-buffers>> first ;
<PRIVATE <PRIVATE
: bind-vertex-array ( vertex-array -- ) : bind-vertex-array ( vertex-array -- )
@ -604,16 +431,43 @@ M: vertex-array dispose
dup first sequence? dup first sequence?
[ bind-named-output-attachments ] [ [ drop ] 2dip bind-unnamed-output-attachments ] if ; [ 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> PRIVATE>
UNION: ?any-framebuffer any-framebuffer POSTPONE: f ;
UNION: transform-feedback-output buffer buffer-range POSTPONE: f ;
TUPLE: render-set TUPLE: render-set
{ primitive-mode primitive-mode read-only } { primitive-mode primitive-mode read-only }
{ vertex-array vertex-array read-only } { vertex-array vertex-array read-only }
{ uniforms uniform-tuple read-only } { uniforms uniform-tuple read-only }
{ indexes vertex-indexes initial: T{ index-range } read-only } { indexes vertex-indexes initial: T{ index-range } read-only }
{ instances ?integer initial: f read-only } { instances ?integer initial: f read-only }
{ framebuffer any-framebuffer initial: system-framebuffer read-only } { framebuffer ?any-framebuffer initial: system-framebuffer read-only }
{ output-attachments sequence initial: { default-attachment } 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> ( x quot-assoc -- render-set )
render-set swap make-tuple ; inline render-set swap make-tuple ; inline
@ -631,7 +485,11 @@ TUPLE: render-set
[ vertex-array>> program-instance>> ] [ uniforms>> ] bi [ vertex-array>> program-instance>> ] [ uniforms>> ] bi
[ bind-uniform-textures ] [ bind-uniforms ] 2bi [ bind-uniform-textures ] [ bind-uniforms ] 2bi
] ]
[ GL_DRAW_FRAMEBUFFER swap framebuffer>> framebuffer-handle glBindFramebuffer ] [
framebuffer>>
[ GL_DRAW_FRAMEBUFFER swap framebuffer-handle glBindFramebuffer ]
[ GL_DRAW_FRAMEBUFFER 0 glBindFramebuffer GL_RASTERIZER_DISCARD glEnable ] if*
]
[ [
[ vertex-array>> program-instance>> ] [ vertex-array>> program-instance>> ]
[ framebuffer>> ] [ framebuffer>> ]
@ -639,10 +497,20 @@ TUPLE: render-set
bind-output-attachments bind-output-attachments
] ]
[ vertex-array>> bind-vertex-array ] [ 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 [ primitive-mode>> ] [ indexes>> ] [ instances>> ] tri
[ render-vertex-indexes-instanced ] [ render-vertex-indexes-instanced ]
[ render-vertex-indexes ] if* [ render-vertex-indexes ] if*
] ]
[ transform-feedback-output>> [ glEndTransformFeedback ] when ]
[ framebuffer>> [ GL_RASTERIZER_DISCARD glDisable ] unless ]
} cleave ; inline } cleave ; inline

20
extra/gpu/shaders/prettyprint/prettyprint.factor
View File

@ -3,10 +3,22 @@ IN: gpu.shaders.prettyprint
M: compile-shader-error error. M: compile-shader-error error.
"The GLSL shader " write "The GLSL shader " write
[ shader>> name>> pprint-short " failed to compile." write nl ] [ shader>> name>> pprint-short " failed to compile." print ]
[ log>> write nl ] bi ; [ log>> print ] bi ;
M: link-program-error error. M: link-program-error error.
"The GLSL program " write "The GLSL program " write
[ shader>> name>> pprint-short " failed to link." write nl ] [ shader>> name>> pprint-short " failed to link." print ]
[ log>> write nl ] bi ; [ 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 ;

87
extra/gpu/shaders/shaders-docs.factor
View File

@ -1,5 +1,6 @@
! (c)2009 Joe Groff bsd license ! (c)2009 Joe Groff bsd license
USING: help.markup help.syntax kernel math multiline quotations strings ; USING: alien.syntax classes gpu.buffers help.markup help.syntax
images kernel math multiline quotations sequences strings ;
IN: gpu.shaders IN: gpu.shaders
HELP: <program-instance> HELP: <program-instance>
@ -16,9 +17,17 @@ HELP: <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." } ; { $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: HELP: GLSL-PROGRAM:
{ $syntax "GLSL-PROGRAM: program-name shader shader ... shader ;" } { $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." } ; { $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: HELP: GLSL-SHADER-FILE:
{ $syntax "GLSL-SHADER-FILE: shader-name shader-kind \"filename\"" } { $syntax "GLSL-SHADER-FILE: shader-name shader-kind \"filename\"" }
@ -32,6 +41,18 @@ 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." } ; { $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 { POSTPONE: GLSL-PROGRAM: POSTPONE: GLSL-SHADER-FILE: POSTPONE: GLSL-SHADER: } related-words
HELP: attribute-index HELP: attribute-index
@ -41,6 +62,15 @@ HELP: attribute-index
} }
{ $description "Returns the numeric index of the vertex attribute named " { $snippet "attribute-name" } " in " { $snippet "program-instance" } "." } ; { $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 HELP: compile-shader-error
{ $class-description "An error compiling the source for a " { $link shader } "." { $class-description "An error compiling the source for a " { $link shader } "."
{ $list { $list
@ -48,6 +78,18 @@ HELP: compile-shader-error
{ "The " { $snippet "log" } " slot contains the error string from the GLSL compiler." } { "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 HELP: fragment-shader
{ $class-description "This " { $link shader-kind } " indicates that a " { $link shader } " is a fragment shader." } ; { $class-description "This " { $link shader-kind } " indicates that a " { $link shader } " is a fragment shader." } ;
@ -93,6 +135,15 @@ HELP: shader-kind
{ { $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." } { { $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 HELP: uniform-index
{ $values { $values
{ "program-instance" program-instance } { "uniform-name" string } { "program-instance" program-instance } { "uniform-name" string }
@ -103,6 +154,29 @@ HELP: uniform-index
HELP: vertex-shader HELP: vertex-shader
{ $class-description "This " { $link shader-kind } " indicates that a " { $link shader } " is a 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" 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." "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-PROGRAM: }
@ -111,6 +185,11 @@ ARTICLE: "gpu.shaders" "Shader objects"
"A program must be instantiated for each graphics context it is used in:" "A program must be instantiated for each graphics context it is used in:"
{ $subsection <program-instance> } { $subsection <program-instance> }
"Program instances can be updated on the fly, allowing for interactive development of shaders:" "Program instances can be updated on the fly, allowing for interactive development of shaders:"
{ $subsection refresh-program } ; { $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" ABOUT: "gpu.shaders"

303
extra/gpu/shaders/shaders.factor
View File

@ -1,17 +1,35 @@
! (c)2009 Joe Groff bsd license ! (c)2009 Joe Groff bsd license
USING: accessors arrays assocs combinators USING: accessors alien alien.c-types alien.strings
combinators.short-circuit definitions destructors gpu alien.structs arrays assocs byte-arrays classes.mixin
io.encodings.ascii io.files io.pathnames kernel lexer classes.parser classes.singleton combinators
locals math math.parser memoize multiline namespaces combinators.short-circuit definitions destructors
opengl.gl opengl.shaders parser sequences generic.parser gpu gpu.buffers hashtables images
specialized-arrays.int splitting strings ui.gadgets.worlds io.encodings.ascii io.files io.pathnames kernel lexer literals
variants hashtables vectors vocabs vocabs.loader words locals math math.parser memoize multiline namespaces opengl
words.constant ; 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 IN: gpu.shaders
VARIANT: shader-kind VARIANT: shader-kind
vertex-shader fragment-shader ; 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 TUPLE: shader
{ name word read-only initial: t } { name word read-only initial: t }
{ kind shader-kind read-only } { kind shader-kind read-only }
@ -25,6 +43,7 @@ TUPLE: program
{ filename read-only } { filename read-only }
{ line integer read-only } { line integer read-only }
{ shaders array read-only } { shaders array read-only }
{ feedback-format ?vertex-format read-only }
{ instances hashtable read-only } ; { instances hashtable read-only } ;
TUPLE: shader-instance < gpu-object TUPLE: shader-instance < gpu-object
@ -35,8 +54,206 @@ TUPLE: program-instance < gpu-object
{ program program } { program program }
{ world world } ; { 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 <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 ) : shader-filename ( shader/program -- filename )
dup filename>> [ nip ] [ name>> where first ] if* file-name ; dup filename>> [ nip ] [ name>> where first ] if* file-name ;
@ -69,6 +286,49 @@ TUPLE: program-instance < gpu-object
PRIVATE> 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: compile-shader-error shader log ;
TUPLE: link-program-error program log ; TUPLE: link-program-error program log ;
@ -82,13 +342,6 @@ TUPLE: link-program-error program log ;
DEFER: <shader-instance> DEFER: <shader-instance>
MEMO: uniform-index ( program-instance uniform-name -- index )
[ handle>> ] dip glGetUniformLocation ;
MEMO: attribute-index ( program-instance attribute-name -- index )
[ handle>> ] dip glGetAttribLocation ;
MEMO: output-index ( program-instance output-name -- index )
[ handle>> ] dip glGetFragDataLocation ;
<PRIVATE <PRIVATE
: valid-handle? ( handle -- ? ) : valid-handle? ( handle -- ? )
@ -101,10 +354,12 @@ MEMO: output-index ( program-instance output-name -- index )
[ compile-shader-error ] if ; [ compile-shader-error ] if ;
: (link-program) ( program shader-instances -- program-instance ) : (link-program) ( program shader-instances -- program-instance )
[ handle>> ] map <gl-program> [ [ handle>> ] map ] curry
dup gl-program-ok? [ feedback-format>> [ link-feedback-format ] curry ] bi (gl-program)
[ swap world get \ program-instance boa window-resource ] dup gl-program-ok? [
[ link-program-error ] if ; [ swap world get \ program-instance boa |dispose dup verify-feedback-format ]
with-destructors window-resource
] [ link-program-error ] if ;
: link-program ( program -- program-instance ) : link-program ( program -- program-instance )
dup shaders>> [ <shader-instance> ] map (link-program) ; dup shaders>> [ <shader-instance> ] map (link-program) ;
@ -139,6 +394,14 @@ MEMO: output-index ( program-instance output-name -- index )
world get over instances>> at* world get over instances>> at*
[ nip ] [ drop link-program ] if ; [ 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> PRIVATE>
:: refresh-program ( program -- ) :: refresh-program ( program -- )
@ -191,7 +454,7 @@ SYNTAX: GLSL-PROGRAM:
CREATE-WORD dup CREATE-WORD dup
f f
lexer get line>> lexer get line>>
\ ; parse-until >array [ def>> first ] map \ ; parse-until >array shaders-and-feedback-format
H{ } clone H{ } clone
program boa program boa
define-constant ; define-constant ;

2
extra/gpu/textures/textures.factor
View File

@ -151,7 +151,7 @@ M: cube-map-face texture-data-gl-target
: get-texture-float ( target level enum -- value ) : get-texture-float ( target level enum -- value )
0 <float> [ glGetTexLevelParameterfv ] keep *float ; 0 <float> [ glGetTexLevelParameterfv ] keep *float ;
: get-texture-int ( texture level enum -- value ) : get-texture-int ( target level enum -- value )
0 <int> [ glGetTexLevelParameteriv ] keep *int ; 0 <int> [ glGetTexLevelParameteriv ] keep *int ;
: ?product ( x -- y ) : ?product ( x -- y )

2
extra/gpu/util/util.factor
View File

@ -1,5 +1,5 @@
! (c)2009 Joe Groff bsd license ! (c)2009 Joe Groff bsd license
USING: gpu.buffers gpu.render gpu.textures images kernel USING: gpu.buffers gpu.render gpu.shaders gpu.textures images kernel
specialized-arrays.float ; specialized-arrays.float ;
IN: gpu.util IN: gpu.util