extra/gpu/shaders/shaders.factor

   1 ! (c)2009 Joe Groff bsd license
   2 USING: accessors alien alien.c-types alien.data alien.strings
   3 arrays assocs byte-arrays classes.mixin classes.parser
   4 classes.singleton classes.struct combinators combinators.short-circuit
   5 definitions destructors fry generic.parser gpu gpu.buffers gpu.private
   6 gpu.state hashtables images io.encodings.ascii io.files io.pathnames
   7 kernel lexer literals locals math math.parser memoize multiline namespaces
   8 opengl opengl.gl opengl.shaders parser quotations sequences
   9 specialized-arrays splitting strings tr ui.gadgets.worlds
  10 variants vectors vocabs vocabs.loader vocabs.parser words
  11 words.constant half-floats typed ;
  12 QUALIFIED-WITH: alien.c-types c
  13 SPECIALIZED-ARRAY: int
  14 SPECIALIZED-ARRAY: void*
  15 IN: gpu.shaders
  16
  17 VARIANT: shader-kind
  18     vertex-shader fragment-shader ;
  19
  20 UNION: ?string string POSTPONE: f ;
  21
  22 ERROR: too-many-feedback-formats-error formats ;
  23 ERROR: invalid-link-feedback-format-error format ;
  24 ERROR: inaccurate-feedback-attribute-error attribute ;
  25
  26 TUPLE: vertex-attribute
  27     { name            ?string        read-only initial: f }
  28     { component-type  component-type read-only initial: float-components }
  29     { dim             integer        read-only initial: 4 }
  30     { normalize?      boolean        read-only initial: f } ;
  31
  32 MIXIN: vertex-format
  33 UNION: ?vertex-format vertex-format POSTPONE: f ;
  34
  35 TUPLE: shader
  36     { name word read-only initial: t }
  37     { kind shader-kind read-only }
  38     { filename read-only }
  39     { line integer read-only }
  40     { source string }
  41     { instances hashtable read-only } ;
  42
  43 TUPLE: program
  44     { name word read-only initial: t }
  45     { filename read-only }
  46     { line integer read-only }
  47     { shaders array read-only }
  48     { vertex-formats array read-only }
  49     { feedback-format ?vertex-format read-only }
  50     { instances hashtable read-only } ;
  51
  52 TUPLE: shader-instance < gpu-object
  53     { shader shader }
  54     { world world } ;
  55
  56 TUPLE: program-instance < gpu-object
  57     { program program }
  58     { world world } ;
  59
  60 GENERIC: vertex-format-size ( format -- size )
  61
  62 MEMO: uniform-index ( program-instance uniform-name -- index )
  63     [ handle>> ] dip glGetUniformLocation ;
  64 MEMO: attribute-index ( program-instance attribute-name -- index )
  65     [ handle>> ] dip glGetAttribLocation ;
  66 MEMO: output-index ( program-instance output-name -- index )
  67     [ handle>> ] dip glGetFragDataLocation ;
  68
  69 : vertex-format-attributes ( vertex-format -- attributes )
  70     "vertex-format-attributes" word-prop ; inline
  71
  72 <PRIVATE
  73
  74 TR: hyphens>underscores "-" "_" ;
  75
  76 : gl-vertex-type ( component-type -- gl-type )
  77     {
  78         { ubyte-components          [ GL_UNSIGNED_BYTE  ] }
  79         { ushort-components         [ GL_UNSIGNED_SHORT ] }
  80         { uint-components           [ GL_UNSIGNED_INT   ] }
  81         { half-components           [ GL_HALF_FLOAT     ] }
  82         { float-components          [ GL_FLOAT          ] }
  83         { byte-integer-components   [ GL_BYTE           ] }
  84         { short-integer-components  [ GL_SHORT          ] }
  85         { int-integer-components    [ GL_INT            ] }
  86         { ubyte-integer-components  [ GL_UNSIGNED_BYTE  ] }
  87         { ushort-integer-components [ GL_UNSIGNED_SHORT ] }
  88         { uint-integer-components   [ GL_UNSIGNED_INT   ] }
  89     } case ;
  90
  91 : vertex-type-size ( component-type -- size )
  92     {
  93         { ubyte-components          [ 1 ] }
  94         { ushort-components         [ 2 ] }
  95         { uint-components           [ 4 ] }
  96         { half-components           [ 2 ] }
  97         { float-components          [ 4 ] }
  98         { byte-integer-components   [ 1 ] }
  99         { short-integer-components  [ 2 ] }
 100         { int-integer-components    [ 4 ] }
 101         { ubyte-integer-components  [ 1 ] }
 102         { ushort-integer-components [ 2 ] }
 103         { uint-integer-components   [ 4 ] }
 104     } case ;
 105
 106 : vertex-attribute-size ( vertex-attribute -- size )
 107     [ component-type>> vertex-type-size ] [ dim>> ] bi * ;
 108
 109 : vertex-attributes-size ( vertex-attributes -- size )
 110     [ vertex-attribute-size ] [ + ] map-reduce ;
 111
 112 : feedback-type= ( component-type dim gl-type -- ? )
 113     [ 2array ] dip {
 114         { $ GL_FLOAT             [ { float-components 1 } ] }
 115         { $ GL_FLOAT_VEC2        [ { float-components 2 } ] }
 116         { $ GL_FLOAT_VEC3        [ { float-components 3 } ] }
 117         { $ GL_FLOAT_VEC4        [ { float-components 4 } ] }
 118         { $ GL_INT               [ { int-integer-components 1 } ] }
 119         { $ GL_INT_VEC2          [ { int-integer-components 2 } ] }
 120         { $ GL_INT_VEC3          [ { int-integer-components 3 } ] }
 121         { $ GL_INT_VEC4          [ { int-integer-components 4 } ] }
 122         { $ GL_UNSIGNED_INT      [ { uint-integer-components 1 } ] }
 123         { $ GL_UNSIGNED_INT_VEC2 [ { uint-integer-components 2 } ] }
 124         { $ GL_UNSIGNED_INT_VEC3 [ { uint-integer-components 3 } ] }
 125         { $ GL_UNSIGNED_INT_VEC4 [ { uint-integer-components 4 } ] }
 126     } case = ;
 127
 128 :: assert-feedback-attribute ( size gl-type name vertex-attribute -- )
 129     {
 130         [ vertex-attribute name>> name = ]
 131         [ size 1 = ]
 132         [ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
 133     } 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
 134
 135 :: (bind-float-vertex-attribute) ( program-instance ptr name dim gl-type normalize? stride offset -- )
 136     program-instance name attribute-index :> idx
 137     idx 0 >= [
 138         idx glEnableVertexAttribArray
 139         idx dim gl-type normalize? stride offset ptr <displaced-alien> glVertexAttribPointer
 140     ] when ; inline
 141
 142 :: (bind-int-vertex-attribute) ( program-instance ptr name dim gl-type stride offset -- )
 143     program-instance name attribute-index :> idx
 144     idx 0 >= [
 145         idx glEnableVertexAttribArray
 146         idx dim gl-type stride offset ptr <displaced-alien> glVertexAttribIPointer
 147     ] when ; inline
 148
 149 :: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
 150     vertex-attribute name>> hyphens>underscores :> name
 151     vertex-attribute component-type>>           :> type
 152     type gl-vertex-type                         :> gl-type
 153     vertex-attribute dim>>                      :> dim
 154     vertex-attribute normalize?>> >c-bool       :> normalize?
 155     vertex-attribute vertex-attribute-size      :> size
 156
 157     stride offset size +
 158     {
 159         { [ name not ] [ [ 2drop ] ] }
 160         {
 161             [ type unnormalized-integer-components? ]
 162             [ { name dim gl-type stride offset (bind-int-vertex-attribute) } >quotation ]
 163         }
 164         [ { name dim gl-type normalize? stride offset (bind-float-vertex-attribute) } >quotation ]
 165     } cond ;
 166
 167 :: [bind-vertex-format] ( vertex-attributes -- quot )
 168     vertex-attributes vertex-attributes-size :> stride
 169     stride 0 vertex-attributes [ [bind-vertex-attribute] ] { } map-as 2nip :> attributes-cleave
 170     { attributes-cleave 2cleave } >quotation :> with-block
 171
 172     { drop vertex-buffer with-block with-buffer-ptr } >quotation ;
 173
 174 :: [link-feedback-format] ( vertex-attributes -- quot )
 175     vertex-attributes [ name>> not ] any?
 176     [ [ nip invalid-link-feedback-format-error ] ] [
 177         vertex-attributes
 178         [ name>> ascii malloc-string ]
 179         void*-array{ } map-as :> varying-names
 180         vertex-attributes length :> varying-count
 181         { drop varying-count varying-names GL_INTERLEAVED_ATTRIBS glTransformFeedbackVaryings }
 182         >quotation
 183     ] if ;
 184
 185 :: [verify-feedback-attribute] ( vertex-attribute index -- quot )
 186     vertex-attribute name>> :> name
 187     name length 1 + :> name-buffer-length
 188     {
 189         index name-buffer-length dup
 190         [ f 0 <int> 0 <int> ] dip <byte-array>
 191         [ glGetTransformFeedbackVarying ] 3keep
 192         ascii alien>string
 193         vertex-attribute assert-feedback-attribute
 194     } >quotation ;
 195
 196 :: [verify-feedback-format] ( vertex-attributes -- quot )
 197     vertex-attributes [ [verify-feedback-attribute] ] map-index :> verify-cleave
 198     { drop verify-cleave cleave } >quotation ;
 199
 200 GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- )
 201
 202 GENERIC: link-feedback-format ( program-handle format -- )
 203
 204 M: f link-feedback-format
 205     2drop ;
 206
 207 : link-vertex-formats ( program-handle formats -- )
 208     [ vertex-format-attributes [ name>> ] map sift ] map concat
 209     swap '[ [ _ ] 2dip swap glBindAttribLocation ] each-index ;
 210
 211 GENERIC: (verify-feedback-format) ( program-instance format -- )
 212
 213 M: f (verify-feedback-format)
 214     2drop ;
 215
 216 : verify-feedback-format ( program-instance -- )
 217     dup program>> feedback-format>> (verify-feedback-format) ;
 218
 219 : define-vertex-format-methods ( class vertex-attributes -- )
 220     {
 221         [
 222             [ \ bind-vertex-format create-method-in ] dip
 223             [bind-vertex-format] define
 224         ] [
 225             [ \ link-feedback-format create-method-in ] dip
 226             [link-feedback-format] define
 227         ] [
 228             [ \ (verify-feedback-format) create-method-in ] dip
 229             [verify-feedback-format] define
 230         ] [
 231             [ \ vertex-format-size create-method-in ] dip
 232             [ \ drop ] dip vertex-attributes-size [ ] 2sequence define
 233         ]
 234     } 2cleave ;
 235
 236 : component-type>c-type ( component-type -- c-type )
 237     {
 238         { ubyte-components [ c:uchar ] }
 239         { ushort-components [ c:ushort ] }
 240         { uint-components [ c:uint ] }
 241         { half-components [ half ] }
 242         { float-components [ c:float ] }
 243         { byte-integer-components [ c:char ] }
 244         { ubyte-integer-components [ c:uchar ] }
 245         { short-integer-components [ c:short ] }
 246         { ushort-integer-components [ c:ushort ] }
 247         { int-integer-components [ c:int ] }
 248         { uint-integer-components [ c:uint ] }
 249     } case ;
 250
 251 : c-array-dim ( type dim -- type' )
 252     dup 1 = [ drop ] [ 2array ] if ;
 253
 254 SYMBOL: padding-no
 255 padding-no [ 0 ] initialize
 256
 257 : padding-name ( -- name )
 258     "padding-"
 259     padding-no get number>string append
 260     "(" ")" surround
 261     padding-no inc ;
 262
 263 : vertex-attribute>struct-slot ( vertex-attribute -- struct-slot-spec )
 264     [ name>> [ padding-name ] unless* ]
 265     [ [ component-type>> component-type>c-type ] [ dim>> c-array-dim ] bi ] bi
 266     { } <struct-slot-spec> ;
 267
 268 : shader-filename ( shader/program -- filename )
 269     dup filename>> [ nip ] [ name>> where first ] if* file-name ;
 270
 271 : numbered-log-line? ( log-line-components -- ? )
 272     {
 273         [ length 4 >= ]
 274         [ third string>number ]
 275     } 1&& ;
 276
 277 : replace-log-line-number ( object log-line -- log-line' )
 278     ":" split dup numbered-log-line? [
 279         {
 280             [ nip first ]
 281             [ drop shader-filename " " prepend ]
 282             [ [ line>> ] [ third string>number ] bi* + number>string ]
 283             [ nip 3 tail ]
 284         } 2cleave [ 3array ] dip append
 285     ] [ nip ] if ":" join ;
 286
 287 : replace-log-line-numbers ( object log -- log' )
 288     "\n" split harvest
 289     [ replace-log-line-number ] with map
 290     "\n" join ;
 291
 292 : gl-shader-kind ( shader-kind -- shader-kind )
 293     {
 294         { vertex-shader [ GL_VERTEX_SHADER ] }
 295         { fragment-shader [ GL_FRAGMENT_SHADER ] }
 296     } case ;
 297
 298 PRIVATE>
 299
 300 : define-vertex-format ( class vertex-attributes -- )
 301     [
 302         [
 303             [ define-singleton-class ]
 304             [ vertex-format add-mixin-instance ]
 305             [ ] tri
 306         ] [ define-vertex-format-methods ] bi*
 307     ]
 308     [ "vertex-format-attributes" set-word-prop ] 2bi ;
 309
 310 SYNTAX: VERTEX-FORMAT:
 311     CREATE-CLASS parse-definition
 312     [ first4 vertex-attribute boa ] map
 313     define-vertex-format ;
 314
 315 : define-vertex-struct ( class vertex-format -- )
 316     vertex-format-attributes [ vertex-attribute>struct-slot ] map
 317     define-struct-class ;
 318
 319 SYNTAX: VERTEX-STRUCT:
 320     CREATE-CLASS scan-word define-vertex-struct ;
 321
 322 TUPLE: vertex-array-object < gpu-object
 323     { program-instance program-instance read-only }
 324     { vertex-buffers sequence read-only } ;
 325
 326 TUPLE: vertex-array-collection
 327     { vertex-formats sequence read-only }
 328     { program-instance program-instance read-only } ;
 329
 330 UNION: vertex-array
 331     vertex-array-object vertex-array-collection ;
 332
 333 M: vertex-array-object dispose
 334     [ [ delete-vertex-array ] when* f ] change-handle drop ;
 335
 336 : ?>buffer-ptr ( buffer/ptr -- buffer-ptr )
 337     dup buffer-ptr? [ 0 <buffer-ptr> ] unless ; inline
 338 : ?>buffer ( buffer/ptr -- buffer )
 339     dup buffer? [ buffer>> ] unless ; inline
 340
 341 <PRIVATE
 342
 343 : normalize-vertex-formats ( vertex-formats -- vertex-formats' )
 344     [ first2 [ ?>buffer-ptr ] dip 2array ] map ; inline
 345
 346 : (bind-vertex-array) ( vertex-formats program-instance -- )
 347     '[ _ swap first2 bind-vertex-format ] each ; inline
 348
 349 : (reset-vertex-array) ( -- )
 350     GL_MAX_VERTEX_ATTRIBS get-gl-int iota [ glDisableVertexAttribArray ] each ; inline
 351
 352 :: <multi-vertex-array-object> ( vertex-formats program-instance -- vertex-array )
 353     gen-vertex-array :> handle
 354     handle glBindVertexArray
 355
 356     vertex-formats normalize-vertex-formats program-instance (bind-vertex-array)
 357
 358     handle program-instance vertex-formats [ first ?>buffer ] map
 359     vertex-array-object boa window-resource ; inline
 360
 361 : <multi-vertex-array-collection> ( vertex-formats program-instance -- vertex-array )
 362     [ normalize-vertex-formats ] dip vertex-array-collection boa ; inline
 363
 364 :: <vertex-array-object> ( vertex-buffer program-instance format -- vertex-array )
 365     gen-vertex-array :> handle
 366     handle glBindVertexArray
 367     program-instance vertex-buffer ?>buffer-ptr format bind-vertex-format
 368     handle program-instance vertex-buffer ?>buffer 1array
 369     vertex-array-object boa window-resource ; inline
 370
 371 : <vertex-array-collection> ( vertex-buffer program-instance format -- vertex-array )
 372     swap [ [ ?>buffer-ptr ] dip 2array 1array ] dip <multi-vertex-array-collection> ; inline
 373
 374 PRIVATE>
 375
 376 GENERIC: bind-vertex-array ( vertex-array -- )
 377
 378 M: vertex-array-object bind-vertex-array
 379     handle>> glBindVertexArray ; inline
 380
 381 M: vertex-array-collection bind-vertex-array
 382     (reset-vertex-array)
 383     [ vertex-formats>> ] [ program-instance>> ] bi (bind-vertex-array) ; inline
 384
 385 : <multi-vertex-array> ( vertex-formats program-instance -- vertex-array )
 386     has-vertex-array-objects? get
 387     [ <multi-vertex-array-object> ]
 388     [ <multi-vertex-array-collection> ] if ; inline
 389
 390 : <vertex-array*> ( vertex-buffer program-instance format -- vertex-array )
 391     has-vertex-array-objects? get
 392     [ <vertex-array-object> ]
 393     [ <vertex-array-collection> ] if ; inline
 394
 395 : <vertex-array> ( vertex-buffer program-instance -- vertex-array )
 396     dup program>> vertex-formats>> first <vertex-array*> ; inline
 397
 398 GENERIC: vertex-array-buffers ( vertex-array -- buffers )
 399
 400 M: vertex-array-object vertex-array-buffers
 401     vertex-buffers>> ; inline
 402
 403 M: vertex-array-collection vertex-array-buffers
 404     vertex-formats>> [ first buffer>> ] map ; inline
 405
 406 : vertex-array-buffer ( vertex-array: vertex-array -- vertex-buffer: buffer )
 407     vertex-array-buffers first ; inline
 408
 409 TUPLE: compile-shader-error shader log ;
 410 TUPLE: link-program-error program log ;
 411
 412 : compile-shader-error ( shader instance -- * )
 413     [ dup ] dip [ gl-shader-info-log ] [ delete-gl-shader ] bi replace-log-line-numbers
 414     \ compile-shader-error boa throw ;
 415
 416 : link-program-error ( program instance -- * )
 417     [ dup ] dip [ gl-program-info-log ] [ delete-gl-program ] bi replace-log-line-numbers
 418     \ link-program-error boa throw ;
 419
 420 DEFER: <shader-instance>
 421
 422 <PRIVATE
 423
 424 : valid-handle? ( handle -- ? )
 425     { [ ] [ zero? not ] } 1&& ;
 426
 427 : compile-shader ( shader -- instance )
 428     [ ] [ source>> ] [ kind>> gl-shader-kind ] tri <gl-shader>
 429     dup gl-shader-ok?
 430     [ swap world get \ shader-instance boa window-resource ]
 431     [ compile-shader-error ] if ;
 432
 433 : (link-program) ( program shader-instances -- program-instance )
 434     '[ _ [ handle>> ] map ]
 435     [
 436         [ vertex-formats>> ] [ feedback-format>> ] bi
 437         '[ [ _ link-vertex-formats ] [ _ link-feedback-format ] bi ]
 438     ] bi (gl-program)
 439     dup gl-program-ok?  [
 440         [ swap world get \ program-instance boa |dispose dup verify-feedback-format ]
 441         with-destructors window-resource
 442     ] [ link-program-error ] if ;
 443
 444 : link-program ( program -- program-instance )
 445     dup shaders>> [ <shader-instance> ] map (link-program) ;
 446
 447 : in-word's-path ( word kind filename -- word kind filename' )
 448     [ over ] dip [ where first parent-directory ] dip append-path ;
 449
 450 : become-shader-instance ( shader-instance new-shader-instance -- )
 451     handle>> [ swap delete-gl-shader ] curry change-handle drop ;
 452
 453 : refresh-shader-source ( shader -- )
 454     dup filename>>
 455     [ ascii file-contents >>source drop ]
 456     [ drop ] if* ;
 457
 458 : become-program-instance ( program-instance new-program-instance -- )
 459     handle>> [ swap delete-gl-program-only ] curry change-handle drop ;
 460
 461 : reset-memos ( -- )
 462     \ uniform-index reset-memoized
 463     \ attribute-index reset-memoized
 464     \ output-index reset-memoized ;
 465
 466 : ?delete-at ( key assoc value -- )
 467     2over at = [ delete-at ] [ 2drop ] if ;
 468
 469 : find-shader-instance ( shader -- instance )
 470     world get over instances>> at*
 471     [ nip ] [ drop compile-shader ] if ;
 472
 473 : find-program-instance ( program -- instance )
 474     world get over instances>> at*
 475     [ nip ] [ drop link-program ] if ;
 476
 477 TUPLE: feedback-format
 478     { vertex-format ?vertex-format read-only } ;
 479
 480 : validate-feedback-format ( sequence -- vertex-format/f )
 481     dup length 1 <=
 482     [ [ f ] [ first vertex-format>> ] if-empty ]
 483     [ too-many-feedback-formats-error ] if ;
 484
 485 : ?shader ( object -- shader/f )
 486     dup word? [ def>> first dup shader? [ drop f ] unless ] [ drop f ] if ;
 487
 488 : shaders-and-formats ( words -- shaders vertex-formats feedback-format )
 489     [ [ ?shader ] map sift ]
 490     [ [ vertex-format-attributes ] filter ]
 491     [ [ feedback-format? ] filter validate-feedback-format ] tri ;
 492
 493 PRIVATE>
 494
 495 SYNTAX: feedback-format:
 496     scan-object feedback-format boa suffix! ;
 497
 498 TYPED:: refresh-program ( program: program -- )
 499     program shaders>> [ refresh-shader-source ] each
 500     program instances>> [| world old-instance |
 501         old-instance valid-handle? [
 502             world [
 503                 [
 504                     program shaders>> [ compile-shader |dispose ] map :> new-shader-instances
 505                     program new-shader-instances (link-program) |dispose :> new-program-instance
 506
 507                     old-instance new-program-instance become-program-instance
 508                     new-shader-instances [| new-shader-instance |
 509                         world new-shader-instance shader>> instances>> at
 510                             new-shader-instance become-shader-instance
 511                     ] each
 512                 ] with-destructors
 513             ] with-gl-context
 514         ] when
 515     ] assoc-each
 516     reset-memos ;
 517
 518 TYPED: <shader-instance> ( shader: shader -- instance: shader-instance )
 519     [ find-shader-instance dup world get ] keep instances>> set-at ;
 520
 521 TYPED: <program-instance> ( program: program -- instance: program-instance )
 522     [ find-program-instance dup world get ] keep instances>> set-at ;
 523
 524 <PRIVATE
 525
 526 : old-instances ( name -- instances )
 527     dup constant? [
 528         execute( -- s/p ) dup { [ shader? ] [ program? ] } 1||
 529         [ instances>> ] [ drop H{ } clone ] if
 530     ] [ drop H{ } clone ] if ;
 531
 532 PRIVATE>
 533
 534 SYNTAX: GLSL-SHADER:
 535     CREATE dup
 536     dup old-instances [
 537         scan-word
 538         f
 539         lexer get line>>
 540         parse-here
 541     ] dip
 542     shader boa
 543     over reset-generic
 544     define-constant ;
 545
 546 SYNTAX: GLSL-SHADER-FILE:
 547     CREATE dup
 548     dup old-instances [
 549         scan-word execute( -- kind )
 550         scan-object in-word's-path
 551         0
 552         over ascii file-contents
 553     ] dip
 554     shader boa
 555     over reset-generic
 556     define-constant ;
 557
 558 SYNTAX: GLSL-PROGRAM:
 559     CREATE dup
 560     dup old-instances [
 561         f
 562         lexer get line>>
 563         \ ; parse-until >array shaders-and-formats
 564     ] dip
 565     program boa
 566     over reset-generic
 567     define-constant ;
 568
 569 M: shader-instance dispose
 570     [ dup valid-handle? [ delete-gl-shader ] [ drop ] if f ] change-handle
 571     [ world>> ] [ shader>> instances>> ] [ ] tri ?delete-at ;
 572
 573 M: program-instance dispose
 574     [ dup valid-handle? [ delete-gl-program-only ] [ drop ] if f ] change-handle
 575     [ world>> ] [ program>> instances>> ] [ ] tri ?delete-at
 576     reset-memos ;
 577
 578 "prettyprint" "gpu.shaders.prettyprint" require-when