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 generic.parser gpu gpu.buffers hashtables
   6 images io.encodings.ascii io.files io.pathnames kernel lexer
   7 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     { feedback-format ?vertex-format read-only }
  49     { instances hashtable read-only } ;
  50
  51 TUPLE: shader-instance < gpu-object
  52     { shader shader }
  53     { world world } ;
  54
  55 TUPLE: program-instance < gpu-object
  56     { program program }
  57     { world world } ;
  58
  59 GENERIC: vertex-format-size ( format -- size )
  60
  61 MEMO: uniform-index ( program-instance uniform-name -- index )
  62     [ handle>> ] dip glGetUniformLocation ;
  63 MEMO: attribute-index ( program-instance attribute-name -- index )
  64     [ handle>> ] dip glGetAttribLocation ;
  65 MEMO: output-index ( program-instance output-name -- index )
  66     [ handle>> ] dip glGetFragDataLocation ;
  67
  68 <PRIVATE
  69
  70 TR: hyphens>underscores "-" "_" ;
  71
  72 : gl-vertex-type ( component-type -- gl-type )
  73     {
  74         { ubyte-components          [ GL_UNSIGNED_BYTE  ] }
  75         { ushort-components         [ GL_UNSIGNED_SHORT ] }
  76         { uint-components           [ GL_UNSIGNED_INT   ] }
  77         { half-components           [ GL_HALF_FLOAT     ] }
  78         { float-components          [ GL_FLOAT          ] }
  79         { byte-integer-components   [ GL_BYTE           ] }
  80         { short-integer-components  [ GL_SHORT          ] }
  81         { int-integer-components    [ GL_INT            ] }
  82         { ubyte-integer-components  [ GL_UNSIGNED_BYTE  ] }
  83         { ushort-integer-components [ GL_UNSIGNED_SHORT ] }
  84         { uint-integer-components   [ GL_UNSIGNED_INT   ] }
  85     } case ;
  86
  87 : vertex-type-size ( component-type -- size )
  88     {
  89         { ubyte-components          [ 1 ] }
  90         { ushort-components         [ 2 ] }
  91         { uint-components           [ 4 ] }
  92         { half-components           [ 2 ] }
  93         { float-components          [ 4 ] }
  94         { byte-integer-components   [ 1 ] }
  95         { short-integer-components  [ 2 ] }
  96         { int-integer-components    [ 4 ] }
  97         { ubyte-integer-components  [ 1 ] }
  98         { ushort-integer-components [ 2 ] }
  99         { uint-integer-components   [ 4 ] }
 100     } case ;
 101
 102 : vertex-attribute-size ( vertex-attribute -- size )
 103     [ component-type>> vertex-type-size ] [ dim>> ] bi * ;
 104
 105 : vertex-attributes-size ( vertex-attributes -- size )
 106     [ vertex-attribute-size ] [ + ] map-reduce ;
 107
 108 : feedback-type= ( component-type dim gl-type -- ? )
 109     [ 2array ] dip {
 110         { $ GL_FLOAT             [ { float-components 1 } ] }
 111         { $ GL_FLOAT_VEC2        [ { float-components 2 } ] }
 112         { $ GL_FLOAT_VEC3        [ { float-components 3 } ] }
 113         { $ GL_FLOAT_VEC4        [ { float-components 4 } ] }
 114         { $ GL_INT               [ { int-integer-components 1 } ] }
 115         { $ GL_INT_VEC2          [ { int-integer-components 2 } ] }
 116         { $ GL_INT_VEC3          [ { int-integer-components 3 } ] }
 117         { $ GL_INT_VEC4          [ { int-integer-components 4 } ] }
 118         { $ GL_UNSIGNED_INT      [ { uint-integer-components 1 } ] }
 119         { $ GL_UNSIGNED_INT_VEC2 [ { uint-integer-components 2 } ] }
 120         { $ GL_UNSIGNED_INT_VEC3 [ { uint-integer-components 3 } ] }
 121         { $ GL_UNSIGNED_INT_VEC4 [ { uint-integer-components 4 } ] }
 122     } case = ;
 123
 124 :: assert-feedback-attribute ( size gl-type name vertex-attribute -- )
 125     {
 126         [ vertex-attribute name>> name = ]
 127         [ size 1 = ]
 128         [ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
 129     } 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
 130
 131 :: (bind-float-vertex-attribute) ( program-instance ptr name dim gl-type normalize? stride offset -- )
 132     program-instance name attribute-index :> idx
 133     idx 0 >= [
 134         idx glEnableVertexAttribArray
 135         idx dim gl-type normalize? stride offset ptr <displaced-alien> glVertexAttribPointer
 136     ] when ; inline
 137
 138 :: (bind-int-vertex-attribute) ( program-instance ptr name dim gl-type stride offset -- )
 139     program-instance name attribute-index :> idx
 140     idx 0 >= [
 141         idx glEnableVertexAttribArray
 142         idx dim gl-type stride offset ptr <displaced-alien> glVertexAttribIPointer
 143     ] when ; inline
 144
 145 :: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
 146     vertex-attribute name>> hyphens>underscores :> name
 147     vertex-attribute component-type>>           :> type
 148     type gl-vertex-type                         :> gl-type
 149     vertex-attribute dim>>                      :> dim
 150     vertex-attribute normalize?>> >c-bool       :> normalize?
 151     vertex-attribute vertex-attribute-size      :> size
 152
 153     stride offset size +
 154     {
 155         { [ name not ] [ [ 2drop ] ] }
 156         {
 157             [ type unnormalized-integer-components? ]
 158             [ { name dim gl-type stride offset (bind-int-vertex-attribute) } >quotation ]
 159         }
 160         [ { name dim gl-type normalize? stride offset (bind-float-vertex-attribute) } >quotation ]
 161     } cond ;
 162
 163 :: [bind-vertex-format] ( vertex-attributes -- quot )
 164     vertex-attributes vertex-attributes-size :> stride
 165     stride 0 vertex-attributes [ [bind-vertex-attribute] ] { } map-as 2nip :> attributes-cleave
 166     { attributes-cleave 2cleave } >quotation :> with-block
 167
 168     { drop vertex-buffer with-block with-buffer-ptr } >quotation ;
 169
 170 :: [link-feedback-format] ( vertex-attributes -- quot )
 171     vertex-attributes [ name>> not ] any?
 172     [ [ nip invalid-link-feedback-format-error ] ] [
 173         vertex-attributes
 174         [ name>> ascii malloc-string ]
 175         void*-array{ } map-as :> varying-names
 176         vertex-attributes length :> varying-count
 177         { drop varying-count varying-names GL_INTERLEAVED_ATTRIBS glTransformFeedbackVaryings }
 178         >quotation
 179     ] if ;
 180
 181 :: [verify-feedback-attribute] ( vertex-attribute index -- quot )
 182     vertex-attribute name>> :> name
 183     name length 1 + :> name-buffer-length
 184     {
 185         index name-buffer-length dup
 186         [ f 0 <int> 0 <int> ] dip <byte-array>
 187         [ glGetTransformFeedbackVarying ] 3keep
 188         ascii alien>string
 189         vertex-attribute assert-feedback-attribute
 190     } >quotation ;
 191
 192 :: [verify-feedback-format] ( vertex-attributes -- quot )
 193     vertex-attributes [ [verify-feedback-attribute] ] map-index :> verify-cleave
 194     { drop verify-cleave cleave } >quotation ;
 195
 196 GENERIC: bind-vertex-format ( program-instance buffer-ptr format -- )
 197
 198 GENERIC: link-feedback-format ( program-handle format -- )
 199
 200 M: f link-feedback-format
 201     2drop ;
 202
 203 GENERIC: (verify-feedback-format) ( program-instance format -- )
 204
 205 M: f (verify-feedback-format)
 206     2drop ;
 207
 208 : verify-feedback-format ( program-instance -- )
 209     dup program>> feedback-format>> (verify-feedback-format) ;
 210
 211 : define-vertex-format-methods ( class vertex-attributes -- )
 212     {
 213         [
 214             [ \ bind-vertex-format create-method-in ] dip
 215             [bind-vertex-format] define
 216         ] [
 217             [ \ link-feedback-format create-method-in ] dip
 218             [link-feedback-format] define
 219         ] [
 220             [ \ (verify-feedback-format) create-method-in ] dip
 221             [verify-feedback-format] define
 222         ] [
 223             [ \ vertex-format-size create-method-in ] dip
 224             [ \ drop ] dip vertex-attributes-size [ ] 2sequence define
 225         ]
 226     } 2cleave ;
 227
 228 : component-type>c-type ( component-type -- c-type )
 229     {
 230         { ubyte-components [ c:uchar ] }
 231         { ushort-components [ c:ushort ] }
 232         { uint-components [ c:uint ] }
 233         { half-components [ half ] }
 234         { float-components [ c:float ] }
 235         { byte-integer-components [ c:char ] }
 236         { ubyte-integer-components [ c:uchar ] }
 237         { short-integer-components [ c:short ] }
 238         { ushort-integer-components [ c:ushort ] }
 239         { int-integer-components [ c:int ] }
 240         { uint-integer-components [ c:uint ] }
 241     } case ;
 242
 243 : c-array-dim ( type dim -- type' )
 244     dup 1 = [ drop ] [ 2array ] if ;
 245
 246 SYMBOL: padding-no
 247 padding-no [ 0 ] initialize
 248
 249 : padding-name ( -- name )
 250     "padding-"
 251     padding-no get number>string append
 252     "(" ")" surround
 253     padding-no inc ;
 254
 255 : vertex-attribute>struct-slot ( vertex-attribute -- struct-slot-spec )
 256     [ name>> [ padding-name ] unless* ]
 257     [ [ component-type>> component-type>c-type ] [ dim>> c-array-dim ] bi ] bi
 258     { } <struct-slot-spec> ;
 259
 260 : shader-filename ( shader/program -- filename )
 261     dup filename>> [ nip ] [ name>> where first ] if* file-name ;
 262
 263 : numbered-log-line? ( log-line-components -- ? )
 264     {
 265         [ length 4 >= ]
 266         [ third string>number ]
 267     } 1&& ;
 268
 269 : replace-log-line-number ( object log-line -- log-line' )
 270     ":" split dup numbered-log-line? [
 271         {
 272             [ nip first ]
 273             [ drop shader-filename " " prepend ]
 274             [ [ line>> ] [ third string>number ] bi* + number>string ]
 275             [ nip 3 tail ]
 276         } 2cleave [ 3array ] dip append
 277     ] [ nip ] if ":" join ;
 278
 279 : replace-log-line-numbers ( object log -- log' )
 280     "\n" split harvest
 281     [ replace-log-line-number ] with map
 282     "\n" join ;
 283
 284 : gl-shader-kind ( shader-kind -- shader-kind )
 285     {
 286         { vertex-shader [ GL_VERTEX_SHADER ] }
 287         { fragment-shader [ GL_FRAGMENT_SHADER ] }
 288     } case ;
 289
 290 PRIVATE>
 291
 292 : define-vertex-format ( class vertex-attributes -- )
 293     [
 294         [
 295             [ define-singleton-class ]
 296             [ vertex-format add-mixin-instance ]
 297             [ ] tri
 298         ] [ define-vertex-format-methods ] bi*
 299     ]
 300     [ "vertex-format-attributes" set-word-prop ] 2bi ;
 301
 302 SYNTAX: VERTEX-FORMAT:
 303     CREATE-CLASS parse-definition
 304     [ first4 vertex-attribute boa ] map
 305     define-vertex-format ;
 306
 307 : define-vertex-struct ( class vertex-format -- )
 308     "vertex-format-attributes" word-prop [ vertex-attribute>struct-slot ] map
 309     define-struct-class ;
 310
 311 SYNTAX: VERTEX-STRUCT:
 312     CREATE-CLASS scan-word define-vertex-struct ;
 313
 314 TUPLE: vertex-array < gpu-object
 315     { program-instance program-instance read-only }
 316     { vertex-buffers sequence read-only } ;
 317
 318 M: vertex-array dispose
 319     [ [ delete-vertex-array ] when* f ] change-handle drop ;
 320
 321 : <vertex-array> ( program-instance vertex-formats -- vertex-array )
 322     gen-vertex-array
 323     [ glBindVertexArray [ first2 bind-vertex-format ] with each ]
 324     [ -rot [ first buffer>> ] map vertex-array boa ] 3bi
 325     window-resource ; inline
 326
 327 TYPED: buffer>vertex-array ( vertex-buffer: buffer
 328                              program-instance: program-instance
 329                              format: vertex-format
 330                              --
 331                              vertex-array: vertex-array )
 332     [ swap ] dip
 333     [ 0 <buffer-ptr> ] dip 2array 1array <vertex-array> ; inline
 334
 335 TYPED: vertex-array-buffer ( vertex-array: vertex-array -- vertex-buffer: buffer )
 336     vertex-buffers>> first ;
 337
 338 TUPLE: compile-shader-error shader log ;
 339 TUPLE: link-program-error program log ;
 340
 341 : compile-shader-error ( shader instance -- * )
 342     [ dup ] dip [ gl-shader-info-log ] [ delete-gl-shader ] bi replace-log-line-numbers
 343     \ compile-shader-error boa throw ;
 344
 345 : link-program-error ( program instance -- * )
 346     [ dup ] dip [ gl-program-info-log ] [ delete-gl-program ] bi replace-log-line-numbers
 347     \ link-program-error boa throw ;
 348
 349 DEFER: <shader-instance>
 350
 351 <PRIVATE
 352
 353 : valid-handle? ( handle -- ? )
 354     { [ ] [ zero? not ] } 1&& ;
 355
 356 : compile-shader ( shader -- instance )
 357     [ ] [ source>> ] [ kind>> gl-shader-kind ] tri <gl-shader>
 358     dup gl-shader-ok?
 359     [ swap world get \ shader-instance boa window-resource ]
 360     [ compile-shader-error ] if ;
 361
 362 : (link-program) ( program shader-instances -- program-instance )
 363     [ [ handle>> ] map ] curry
 364     [ feedback-format>> [ link-feedback-format ] curry ] bi (gl-program)
 365     dup gl-program-ok?  [
 366         [ swap world get \ program-instance boa |dispose dup verify-feedback-format ]
 367         with-destructors window-resource
 368     ] [ link-program-error ] if ;
 369
 370 : link-program ( program -- program-instance )
 371     dup shaders>> [ <shader-instance> ] map (link-program) ;
 372
 373 : in-word's-path ( word kind filename -- word kind filename' )
 374     [ over ] dip [ where first parent-directory ] dip append-path ;
 375
 376 : become-shader-instance ( shader-instance new-shader-instance -- )
 377     handle>> [ swap delete-gl-shader ] curry change-handle drop ;
 378
 379 : refresh-shader-source ( shader -- )
 380     dup filename>>
 381     [ ascii file-contents >>source drop ]
 382     [ drop ] if* ;
 383
 384 : become-program-instance ( program-instance new-program-instance -- )
 385     handle>> [ swap delete-gl-program-only ] curry change-handle drop ;
 386
 387 : reset-memos ( -- )
 388     \ uniform-index reset-memoized
 389     \ attribute-index reset-memoized
 390     \ output-index reset-memoized ;
 391
 392 : ?delete-at ( key assoc value -- )
 393     2over at = [ delete-at ] [ 2drop ] if ;
 394
 395 : find-shader-instance ( shader -- instance )
 396     world get over instances>> at*
 397     [ nip ] [ drop compile-shader ] if ;
 398
 399 : find-program-instance ( program -- instance )
 400     world get over instances>> at*
 401     [ nip ] [ drop link-program ] if ;
 402
 403 : shaders-and-feedback-format ( words -- shaders feedback-format )
 404     [ vertex-format? ] partition swap
 405     [ [ def>> first ] map ] [
 406         dup length 1 <=
 407         [ [ f ] [ first ] if-empty ]
 408         [ too-many-feedback-formats-error ] if
 409     ] bi* ;
 410
 411 PRIVATE>
 412
 413 TYPED:: refresh-program ( program: program -- )
 414     program shaders>> [ refresh-shader-source ] each
 415     program instances>> [| world old-instance |
 416         old-instance valid-handle? [
 417             world [
 418                 [
 419                     program shaders>> [ compile-shader |dispose ] map :> new-shader-instances
 420                     program new-shader-instances (link-program) |dispose :> new-program-instance
 421
 422                     old-instance new-program-instance become-program-instance
 423                     new-shader-instances [| new-shader-instance |
 424                         world new-shader-instance shader>> instances>> at
 425                             new-shader-instance become-shader-instance
 426                     ] each
 427                 ] with-destructors
 428             ] with-gl-context
 429         ] when
 430     ] assoc-each
 431     reset-memos ;
 432
 433 TYPED: <shader-instance> ( shader: shader -- instance: shader-instance )
 434     [ find-shader-instance dup world get ] keep instances>> set-at ;
 435
 436 TYPED: <program-instance> ( program: program -- instance: program-instance )
 437     [ find-program-instance dup world get ] keep instances>> set-at ;
 438
 439 <PRIVATE
 440
 441 : old-instances ( name -- instances )
 442     dup constant? [
 443         execute( -- s/p ) dup { [ shader? ] [ program? ] } 1||
 444         [ instances>> ] [ drop H{ } clone ] if
 445     ] [ drop H{ } clone ] if ;
 446
 447 PRIVATE>
 448
 449 SYNTAX: GLSL-SHADER:
 450     CREATE dup
 451     dup old-instances [
 452         scan-word
 453         f
 454         lexer get line>>
 455         parse-here
 456     ] dip
 457     shader boa
 458     over reset-generic
 459     define-constant ;
 460
 461 SYNTAX: GLSL-SHADER-FILE:
 462     CREATE dup
 463     dup old-instances [
 464         scan-word execute( -- kind )
 465         scan-object in-word's-path
 466         0
 467         over ascii file-contents
 468     ] dip
 469     shader boa
 470     over reset-generic
 471     define-constant ;
 472
 473 SYNTAX: GLSL-PROGRAM:
 474     CREATE dup
 475     dup old-instances [
 476         f
 477         lexer get line>>
 478         \ ; parse-until >array shaders-and-feedback-format
 479     ] dip
 480     program boa
 481     over reset-generic
 482     define-constant ;
 483
 484 M: shader-instance dispose
 485     [ dup valid-handle? [ delete-gl-shader ] [ drop ] if f ] change-handle
 486     [ world>> ] [ shader>> instances>> ] [ ] tri ?delete-at ;
 487
 488 M: program-instance dispose
 489     [ dup valid-handle? [ delete-gl-program-only ] [ drop ] if f ] change-handle
 490     [ world>> ] [ program>> instances>> ] [ ] tri ?delete-at
 491     reset-memos ;
 492
 493 "prettyprint" vocab [ "gpu.shaders.prettyprint" require ] when