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 ;
  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-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
 132     vertex-attribute name>> hyphens>underscores :> name
 133     vertex-attribute component-type>>           :> type
 134     type gl-vertex-type                         :> gl-type
 135     vertex-attribute dim>>                      :> dim
 136     vertex-attribute normalize?>> >c-bool       :> normalize?
 137     vertex-attribute vertex-attribute-size      :> size
 138
 139     stride offset size +
 140     {
 141         { [ name not ] [ [ 2drop ] ] }
 142         {
 143             [ type unnormalized-integer-components? ]
 144             [
 145                 {
 146                     name attribute-index [ glEnableVertexAttribArray ] keep
 147                     dim gl-type stride offset
 148                 } >quotation :> dip-block
 149
 150                 { dip-block dip <displaced-alien> glVertexAttribIPointer } >quotation
 151             ]
 152         }
 153         [
 154             {
 155                 name attribute-index [ glEnableVertexAttribArray ] keep
 156                 dim gl-type normalize? stride offset
 157             } >quotation :> dip-block
 158
 159             { dip-block dip <displaced-alien> glVertexAttribPointer } >quotation
 160         ]
 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 ;
 326
 327 : buffer>vertex-array ( vertex-buffer program-instance format -- vertex-array )
 328     [ swap ] dip
 329     [ 0 <buffer-ptr> ] dip 2array 1array <vertex-array> ; inline
 330
 331 : vertex-array-buffer ( vertex-array -- vertex-buffer )
 332     vertex-buffers>> first ;
 333
 334 TUPLE: compile-shader-error shader log ;
 335 TUPLE: link-program-error program log ;
 336
 337 : compile-shader-error ( shader instance -- * )
 338     [ dup ] dip [ gl-shader-info-log ] [ delete-gl-shader ] bi replace-log-line-numbers
 339     \ compile-shader-error boa throw ;
 340
 341 : link-program-error ( program instance -- * )
 342     [ dup ] dip [ gl-program-info-log ] [ delete-gl-program ] bi replace-log-line-numbers
 343     \ link-program-error boa throw ;
 344
 345 DEFER: <shader-instance>
 346
 347 <PRIVATE
 348
 349 : valid-handle? ( handle -- ? )
 350     { [ ] [ zero? not ] } 1&& ;
 351
 352 : compile-shader ( shader -- instance )
 353     [ ] [ source>> ] [ kind>> gl-shader-kind ] tri <gl-shader>
 354     dup gl-shader-ok?
 355     [ swap world get \ shader-instance boa window-resource ]
 356     [ compile-shader-error ] if ;
 357
 358 : (link-program) ( program shader-instances -- program-instance )
 359     [ [ handle>> ] map ] curry
 360     [ feedback-format>> [ link-feedback-format ] curry ] bi (gl-program)
 361     dup gl-program-ok?  [
 362         [ swap world get \ program-instance boa |dispose dup verify-feedback-format ]
 363         with-destructors window-resource
 364     ] [ link-program-error ] if ;
 365
 366 : link-program ( program -- program-instance )
 367     dup shaders>> [ <shader-instance> ] map (link-program) ;
 368
 369 : in-word's-path ( word kind filename -- word kind filename' )
 370     [ over ] dip [ where first parent-directory ] dip append-path ;
 371
 372 : become-shader-instance ( shader-instance new-shader-instance -- )
 373     handle>> [ swap delete-gl-shader ] curry change-handle drop ;
 374
 375 : refresh-shader-source ( shader -- )
 376     dup filename>>
 377     [ ascii file-contents >>source drop ]
 378     [ drop ] if* ;
 379
 380 : become-program-instance ( program-instance new-program-instance -- )
 381     handle>> [ swap delete-gl-program-only ] curry change-handle drop ;
 382
 383 : reset-memos ( -- )
 384     \ uniform-index reset-memoized
 385     \ attribute-index reset-memoized
 386     \ output-index reset-memoized ;
 387
 388 : ?delete-at ( key assoc value -- )
 389     2over at = [ delete-at ] [ 2drop ] if ;
 390
 391 : find-shader-instance ( shader -- instance )
 392     world get over instances>> at*
 393     [ nip ] [ drop compile-shader ] if ;
 394
 395 : find-program-instance ( program -- instance )
 396     world get over instances>> at*
 397     [ nip ] [ drop link-program ] if ;
 398
 399 : shaders-and-feedback-format ( words -- shaders feedback-format )
 400     [ vertex-format? ] partition swap
 401     [ [ def>> first ] map ] [
 402         dup length 1 <=
 403         [ [ f ] [ first ] if-empty ]
 404         [ too-many-feedback-formats-error ] if
 405     ] bi* ;
 406
 407 PRIVATE>
 408
 409 :: refresh-program ( program -- )
 410     program shaders>> [ refresh-shader-source ] each
 411     program instances>> [| world old-instance |
 412         old-instance valid-handle? [
 413             world [
 414                 [
 415                     program shaders>> [ compile-shader |dispose ] map :> new-shader-instances
 416                     program new-shader-instances (link-program) |dispose :> new-program-instance
 417
 418                     old-instance new-program-instance become-program-instance
 419                     new-shader-instances [| new-shader-instance |
 420                         world new-shader-instance shader>> instances>> at
 421                             new-shader-instance become-shader-instance
 422                     ] each
 423                 ] with-destructors
 424             ] with-gl-context
 425         ] when
 426     ] assoc-each
 427     reset-memos ;
 428
 429 : <shader-instance> ( shader -- instance )
 430     [ find-shader-instance dup world get ] keep instances>> set-at ;
 431
 432 : <program-instance> ( program -- instance )
 433     [ find-program-instance dup world get ] keep instances>> set-at ;
 434
 435 <PRIVATE
 436
 437 : old-instances ( name -- instances )
 438     dup constant? [
 439         execute( -- s/p ) dup { [ shader? ] [ program? ] } 1||
 440         [ instances>> ] [ drop H{ } clone ] if
 441     ] [ drop H{ } clone ] if ;
 442
 443 PRIVATE>
 444
 445 SYNTAX: GLSL-SHADER:
 446     CREATE dup
 447     dup old-instances [
 448         scan-word
 449         f
 450         lexer get line>>
 451         parse-here
 452     ] dip
 453     shader boa
 454     over reset-generic
 455     define-constant ;
 456
 457 SYNTAX: GLSL-SHADER-FILE:
 458     CREATE dup
 459     dup old-instances [
 460         scan-word execute( -- kind )
 461         scan-object in-word's-path
 462         0
 463         over ascii file-contents
 464     ] dip
 465     shader boa
 466     over reset-generic
 467     define-constant ;
 468
 469 SYNTAX: GLSL-PROGRAM:
 470     CREATE dup
 471     dup old-instances [
 472         f
 473         lexer get line>>
 474         \ ; parse-until >array shaders-and-feedback-format
 475     ] dip
 476     program boa
 477     over reset-generic
 478     define-constant ;
 479
 480 M: shader-instance dispose
 481     [ dup valid-handle? [ delete-gl-shader ] [ drop ] if f ] change-handle
 482     [ world>> ] [ shader>> instances>> ] [ ] tri ?delete-at ;
 483
 484 M: program-instance dispose
 485     [ dup valid-handle? [ delete-gl-program-only ] [ drop ] if f ] change-handle
 486     [ world>> ] [ program>> instances>> ] [ ] tri ?delete-at
 487     reset-memos ;
 488
 489 "prettyprint" vocab [ "gpu.shaders.prettyprint" require ] when