extra/gpu/shaders/shaders.factor

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