rev: 21c5e6d2f665d0e8b4ff917a51b664c895dab2ed tukan/tukan/gl.sc -rw-r--r-- 17.1 KiB View raw Log this file
21c5e6d2f665 — Leonard Ritter * renamed project from Liminal to Tukan 2 years ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
import .core
using import .libc

define lib
    if (operating-system == 'windows)
        load-library "opengl32.dll"
    else
        load-library "libGL.so"
    import-c "import_gl.c"
        """"
            #include "glad.h"
        list
            \ "-I" (module-dir .. "/../include/glad")
            \ "-I" (module-dir .. "/../include")

using lib filter "^(gl(.+)|GL(.+))$"

fn makegen1 (f)
    fn ()
        var o = 0:u32
        f 1 o
        o as immutable

fn makedel1 (f)
    fn (o)
        var o = o
        f 1 o

syntax-extend
    let names =
        quote
            VertexArray VertexArrays
            Buffer Buffers
            #Texture
            Framebuffer Framebuffers
            TransformFeedback TransformFeedbacks
            Sampler Samplers
            Renderbuffer Renderbuffers

    let loop (names) = names
    if (not (empty? names))
        let pair rest = (decons names)
        let singular plural = (decons (pair as list) 2)
        let singular plural =
            singular as Symbol as string
            plural as Symbol as string
        let glgen = (@ lib (Symbol (.. "glGen" plural)))
        let glcreate = (@ lib (Symbol (.. "glCreate" plural)))
        let gldel = (@ lib (Symbol (.. "glDelete" plural)))
        let glgen1 = (Symbol (.. "glGen" singular))
        let gldel1 = (Symbol (.. "glDel" singular))
        let glcreate1 = (Symbol (.. "glCreate" singular))
        set-scope-symbol! syntax-scope glgen1 (makegen1 glgen)
        set-scope-symbol! syntax-scope gldel1 (makedel1 gldel)
        set-scope-symbol! syntax-scope glcreate1 (makegen1 glcreate)
        loop rest

    set-scope-symbol! syntax-scope 'glGenTexture (makegen1 glGenTextures)
    set-scope-symbol! syntax-scope 'glDelTexture (makedel1 glDeleteTextures)
    set-scope-symbol! syntax-scope 'glGenQuery (makegen1 glGenQueries)
    set-scope-symbol! syntax-scope 'glDelQuery (makedel1 glDeleteQueries)

    syntax-scope

fn glCreateTexture (target)
    var o = 0:u32
    glCreateTextures target 1 o
    load o

fn glCreateQuery (target)
    var o = 0:u32
    glCreateQueries target 1 o
    load o

#-------------------------------------------------------------------------------

fn get-shader-info-log (id)
    var maxlength = 0
    glGetShaderiv id GL_INFO_LOG_LENGTH maxlength
    var infolog @ maxlength : i8
    glGetShaderInfoLog id maxlength maxlength infolog
    string-new (infolog as rawstring) (maxlength as usize)

fn get-program-info-log (pg)
    var maxlength = 0
    glGetProgramiv pg GL_INFO_LOG_LENGTH maxlength
    var infolog @ maxlength : i8
    glGetProgramInfoLog pg maxlength maxlength infolog
    string-new (infolog as rawstring) (maxlength as usize)

fn compile-shader (shader_type source)
    let id = (glCreateShader shader_type)
    var compiled = 0
    let sourceptr = (source as rawstring)

    glShaderSource id 1 (allocaof sourceptr) null
    glCompileShader id
    glGetShaderiv id GL_COMPILE_STATUS compiled
    if (compiled == GL_FALSE)
        let log = (get-shader-info-log id)
        #print (prepend_linenos source)
        print log
        error! "error compiling shader"
    id

fn attach-shaders (program opts...)
    fn getopt (name defvalue)
        let val = (va@ name opts...)
        if (none? val) defvalue
        else val

    fn attach (stage target source)
        if (not (none? source))
            let source =
                if ((typeof source) == string) source
                else
                    compile-glsl stage
                        typify source
                        if (getopt 'debug false)
                            _ 'dump-disassembly 'dump-module

            var sh = (compile-shader (unconst (u32 target)) (unconst source))
            glAttachShader program sh
            return source sh

    fn detach (shader)
        if (not (none? shader))
            glDetachShader program shader
            glDeleteShader shader

    let vertex-source vertex-shader =
        attach 'vertex GL_VERTEX_SHADER (va@ 'vertex opts...)
    let fragment-source fragment-shader =
        attach 'fragment GL_FRAGMENT_SHADER (va@ 'fragment opts...)
    let geometry-source geometry-shader =
        attach 'geometry GL_GEOMETRY_SHADER (va@ 'geometry opts...)
    let compute-source compute-shader =
        attach 'compute GL_COMPUTE_SHADER (va@ 'compute opts...)

    fn ()
        glLinkProgram program
        var linked = 0
        glGetProgramiv program GL_LINK_STATUS linked
        if (linked == GL_FALSE)
            let log = (get-program-info-log program)
            #foreach source sources
                print (prepend_linenos source)
            print log
            error! "error linking shader"
        detach vertex-shader
        detach fragment-shader
        detach geometry-shader
        detach compute-shader
        program

#-------------------------------------------------------------------------------

fn setup-ubo (slot ubo struct_type)
    glNamedBufferData ubo (sizeof struct_type) null GL_DYNAMIC_DRAW
    glBindBuffer GL_UNIFORM_BUFFER ubo
    glBindBufferBase GL_UNIFORM_BUFFER slot ubo
    glBindBuffer GL_UNIFORM_BUFFER 0

fn struct-mapper (struct_type)
    fn (buffer_type)
        "&struct_type <- (GLuint)"
        bitcast
            glMapBufferRange buffer_type 0 (sizeof struct_type)
                | GL_MAP_WRITE_BIT
                    GL_MAP_UNSYNCHRONIZED_BIT
                    GL_MAP_INVALIDATE_BUFFER_BIT
            'from-pointer-type reference (pointer struct_type 'mutable)

fn struct-writer (struct_type)
    fn (buffer_type data)
        "void <- (GLuint &struct_type)"
        glBufferSubData buffer_type 0 (sizeof struct_type) data

fn named-struct-writer (struct_type)
    fn (bufferid data)
        "void <- (GLuint &struct_type)"
        glNamedBufferSubData bufferid 0 (sizeof struct_type) data

#-------------------------------------------------------------------------------

# return image tag, GL image type, GL channel format, GL element type

fn image-format (gl-format)
    match gl-format
        GL_R8 (_    GL_RED  GL_UNSIGNED_BYTE 'R8)
        GL_RG8 (_   GL_RG   GL_UNSIGNED_BYTE 'Rg8)
        GL_RGBA8 (_ GL_RGBA GL_UNSIGNED_BYTE 'Rgba8)

        GL_R16 (_       GL_RED  GL_UNSIGNED_SHORT 'R16)
        GL_RG16 (_      GL_RG   GL_UNSIGNED_SHORT 'Rg16)
        GL_RGBA16 (_    GL_RGBA GL_UNSIGNED_SHORT 'Rgba16)

        GL_R8_SNORM (_      GL_RED  GL_BYTE 'R8Snorm)
        GL_RG8_SNORM (_     GL_RG   GL_BYTE 'Rg8Snorm)
        GL_RGBA8_SNORM (_   GL_RGBA GL_BYTE 'Rgba8Snorm)

        GL_R16_SNORM (_     GL_RED  GL_SHORT 'R16Snorm)
        GL_RG16_SNORM (_    GL_RG   GL_SHORT 'Rg16Snorm)
        GL_RGBA16_SNORM (_  GL_RGBA GL_SHORT 'Rgba16Snorm)

        GL_R8I (_       GL_RED  GL_BYTE 'R8i)
        GL_RG8I (_      GL_RG   GL_BYTE 'Rg8i)
        GL_RGBA8I (_    GL_RGBA GL_BYTE 'Rgba8i)

        GL_R16I (_      GL_RED  GL_SHORT 'R16i)
        GL_RG16I (_     GL_RG   GL_SHORT 'Rg16i)
        GL_RGBA16I (_   GL_RGBA GL_SHORT 'Rgba16i)

        GL_R32I (_      GL_RED  GL_INT 'R32i)
        GL_RG32I (_     GL_RG   GL_INT 'Rg32i)
        GL_RGBA32I (_   GL_RGBA GL_INT 'Rgba32i)

        GL_R8UI (_      GL_RED  GL_BYTE 'R8ui)
        GL_RG8UI (_     GL_RG   GL_BYTE 'Rg8ui)
        GL_RGBA8UI (_   GL_RGBA GL_BYTE 'Rgba8ui)

        GL_R16UI (_     GL_RED  GL_SHORT 'R16ui)
        GL_RG16UI (_    GL_RG   GL_SHORT 'Rg16ui)
        GL_RGBA16UI (_  GL_RGBA GL_SHORT 'Rgba16ui)

        GL_R32UI (_     GL_RED  GL_INT 'R32ui)
        GL_RG32UI (_    GL_RG   GL_INT 'Rg32ui)
        GL_RGBA32UI (_  GL_RGBA GL_INT 'Rgba32ui)

        GL_R16F (_      GL_RED  GL_HALF_FLOAT 'R16f)
        GL_RG16F (_     GL_RG   GL_HALF_FLOAT 'Rg16f)
        GL_RGBA16F (_   GL_RGBA GL_HALF_FLOAT 'Rgba16f)

        GL_R32F (_      GL_RED  GL_FLOAT 'R32f)
        GL_RG32F (_     GL_RG   GL_FLOAT 'Rg32f)
        GL_RGBA32F (_   GL_RGBA GL_FLOAT 'Rgba32f)

        GL_DEPTH_COMPONENT16 (_     GL_DEPTH_COMPONENT  GL_UNSIGNED_INT         'R16)
        GL_DEPTH_COMPONENT32 (_     GL_DEPTH_COMPONENT  GL_UNSIGNED_INT         'R32)
        GL_DEPTH_COMPONENT32F (_    GL_DEPTH_COMPONENT  GL_FLOAT                'R32f)
        GL_DEPTH24_STENCIL8 (_      GL_DEPTH_STENCIL    GL_UNSIGNED_INT_24_8    'R32ui)
        else
            compiler-error! "illegal format"

#-------------------------------------------------------------------------------

fn framebuffer-status (status)
    unconst
        match status
            GL_FRAMEBUFFER_COMPLETE "COMPLETE"
            GL_FRAMEBUFFER_UNDEFINED "UNDEFINED"
            GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT "INCOMPLETE_ATTACHMENT"
            GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT "INCOMPLETE_MISSING_ATTACHMENT"
            GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT "INCOMPLETE_DIMENSIONS"
            GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER "INCOMPLETE_DRAW_BUFFER"
            GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT "INCOMPLETE_FORMATS"
            GL_FRAMEBUFFER_INCOMPLETE_LAYER_COUNT_ARB "INCOMPLETE_LAYER_COUNT"
            GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS "INCOMPLETE_LAYER_TARGETS"
            GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER "INCOMPLETE_READ_BUFFER"
            GL_FRAMEBUFFER_UNSUPPORTED "UNSUPPORTED"
            GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE "INCOMPLETE_MULTISAMPLE"
            GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS "INCOMPLETE_LAYER_TARGETS"
            else "?"

#-------------------------------------------------------------------------------

fn... get-texture-size
    (id : GLuint, level : i32)
        var w = 0
        var h = 0
        glGetTextureLevelParameteriv id level GL_TEXTURE_WIDTH w
        glGetTextureLevelParameteriv id level GL_TEXTURE_HEIGHT h
        return (w as immutable) (h as immutable)
    (id : GLuint)
        get-texture-size id 0

#-------------------------------------------------------------------------------

fn setup-texture (id w h opts...)
    fn getopt (name defvalue)
        let val = (va@ name opts...)
        if (none? val) defvalue
        else val
    let msaa = (getopt 'msaa 0)
    let layers = (getopt 'layers 0)
    let levels = (getopt 'levels 1)

    let use-msaa = (msaa > 0)
    let use-layers = (layers > 0)

    let internal_format = (getopt 'format GL_RGBA8)

    let fixedsamplelocations = GL_TRUE
    if use-msaa
        if use-layers
            glTextureStorage3DMultisample id msaa internal_format w h layers
                fixedsamplelocations
        else
            glTextureStorage2DMultisample id msaa internal_format w h
                fixedsamplelocations
    else
        if use-layers
            glTextureStorage3D id levels internal_format w h layers
        else
            glTextureStorage2D id levels internal_format w h

    if (not use-msaa)
        glTextureParameteri id GL_TEXTURE_WRAP_S GL_CLAMP_TO_BORDER
        glTextureParameteri id GL_TEXTURE_WRAP_T GL_CLAMP_TO_BORDER
        glTextureParameteri id GL_TEXTURE_MIN_FILTER GL_LINEAR
        glTextureParameteri id GL_TEXTURE_MAG_FILTER GL_LINEAR

    id

#-------------------------------------------------------------------------------

fn setup-renderbuffer (id w h opts...)
    fn getopt (name defvalue)
        let val = (va@ name opts...)
        if (none? val) defvalue
        else val

    let msaa = (getopt 'msaa 0)
    let internal_format = (getopt 'format GL_RGBA8)

    glNamedRenderbufferStorageMultisample id msaa internal_format w h
    id

#-------------------------------------------------------------------------------

fn setup-framebuffer (id opts...)
    let keys... = (va-keys opts...)
    let vasz = (va-countof opts...)
    let loop (i target-idx color-layer depth-layer) = 0 0 none none
    if (i < vasz)
        let key = (va@ i keys...)
        let arg = (va@ i opts...)
        let i = (i + 1)
        if (key == 'color-layer)
            loop i target-idx arg depth-layer
        elseif (key == 'color)
            let target = (GL_COLOR_ATTACHMENT0 + target-idx)
            if (none? color-layer)
                glNamedFramebufferTexture id target arg 0
                loop i (target-idx + 1) none depth-layer
            else
                glNamedFramebufferTextureLayer id target arg 0 color-layer
                loop i (target-idx + 1) (color-layer + 1) depth-layer
        elseif (key == 'depth-layer)
            loop i target-idx color-layer arg
        elseif (key == 'depth)
            if (none? depth-layer)
                glNamedFramebufferTexture id GL_DEPTH_ATTACHMENT arg 0
                loop i target-idx color-layer none
            else
                glNamedFramebufferTextureLayer id GL_DEPTH_ATTACHMENT arg 0 depth-layer
                loop i target-idx color-layer (depth-layer + 1)
        elseif (key == 'depth-stencil)
            glNamedFramebufferTexture id GL_DEPTH_STENCIL_ATTACHMENT arg 0
            loop i target-idx color-layer depth-layer
        elseif (key == 'rb-depth-stencil)
            glNamedFramebufferRenderbuffer id GL_DEPTH_STENCIL_ATTACHMENT GL_RENDERBUFFER arg
            loop i target-idx color-layer depth-layer
        elseif (key == 'rb-depth)
            glNamedFramebufferRenderbuffer id GL_DEPTH_ATTACHMENT GL_RENDERBUFFER arg
            loop i target-idx color-layer depth-layer
        else
            compiler-error!
                .. "unknown key for argument: " (repr key)

    var buffers @ target-idx : u32
    let loop (i) = 0
    if (i < target-idx)
        buffers @ i = (GL_COLOR_ATTACHMENT0 + i)
        loop (i + 1)
    glNamedFramebufferDrawBuffers id target-idx buffers

    let status = (glCheckNamedFramebufferStatus id GL_FRAMEBUFFER)

    assert (status == GL_FRAMEBUFFER_COMPLETE)
        .. "Framebuffer incomplete: " (framebuffer-status status)

    id

#-------------------------------------------------------------------------------

fn blit-framebuffer (source target size opts...)
    let target-size-opt = (va@ 'target-size opts...)
    let target-size =
        if (none? target-size-opt) size
        else target-size-opt
    let filter = (va@ 'filter opts...)
    let filter =
        if (none? filter)
            if (none? target-size-opt) GL_NEAREST
            else GL_LINEAR
        else filter
    let bits = (va@ 'bits opts...)
    let bits =
        if (none? bits) GL_COLOR_BUFFER_BIT
        else bits
    glBlitNamedFramebuffer source target
        \ 0 0 size.x size.y
        \ 0 0 target-size.x target-size.y
        \ bits filter

#-------------------------------------------------------------------------------

fn... gl-get-int
    (pname : GLenum)
        var data = 0
        glGetIntegerv pname data
        data as immutable
    (pname : GLenum, index : GLuint)
        var data = 0
        glGetIntegeri_v pname index data
        data as immutable

fn... gl-get-int64
    (pname : GLenum)
        var data = 0:i64
        glGetInteger64v pname data
        data as immutable

#-------------------------------------------------------------------------------

fn print-gl-info ()
    fn print-info (sym)
        let idx ok = (@ lib sym)
        assert ok sym
        let s = (glGetString idx)
        printf "%s: %s\n" ((Symbol->string sym) as rawstring) s

    print-info 'GL_VENDOR
    print-info 'GL_RENDERER
    print-info 'GL_VERSION
    print-info 'GL_SHADING_LANGUAGE_VERSION

fn hook-gl-debug ()
    fn gl-debug-source (source)
        unconst
            match source
                GL_DEBUG_SOURCE_API                "API"
                GL_DEBUG_SOURCE_WINDOW_SYSTEM      "Window System"
                GL_DEBUG_SOURCE_SHADER_COMPILER    "Shader Compiler"
                GL_DEBUG_SOURCE_THIRD_PARTY        "Third Party"
                GL_DEBUG_SOURCE_APPLICATION        "Application"
                GL_DEBUG_SOURCE_OTHER              "Other"
                else                               "?"

    fn gl-debug-type (type_)
        unconst
            match type_
                GL_DEBUG_TYPE_ERROR                "Error"
                GL_DEBUG_TYPE_DEPRECATED_BEHAVIOR  "Deprecated"
                GL_DEBUG_TYPE_UNDEFINED_BEHAVIOR   "Undefined Behavior"
                GL_DEBUG_TYPE_PORTABILITY          "Portability"
                GL_DEBUG_TYPE_PERFORMANCE          "Performance"
                GL_DEBUG_TYPE_OTHER                "Other"
                else                               "?"

    fn gl-debug-severity (severity)
        unconst
            match severity
                GL_DEBUG_SEVERITY_HIGH             "High"
                GL_DEBUG_SEVERITY_MEDIUM           "Medium"
                GL_DEBUG_SEVERITY_LOW              "Low"
                GL_DEBUG_SEVERITY_NOTIFICATION     "Notification"
                else                               "?"

    fn gl-debug-callback (source type_ id_ severity length message userparams)
        #void <- (GLenum GLenum GLuint GLenum GLsizei GLchar* void*)
        fflush (stdout)
        fprintf (stderr) "%s:%s:%x:%s:%s\n"
            (gl-debug-source source) as rawstring
            (gl-debug-type type_) as rawstring
            id_
            (gl-debug-severity severity) as rawstring
            message
        fflush (stderr)
        if (type_ == GL_DEBUG_TYPE_ERROR)
            abort!;
        return;

    glDebugMessageCallback gl-debug-callback null
    # turn off all notifications
    glDebugMessageControl GL_DONT_CARE GL_DONT_CARE
        \ GL_DEBUG_SEVERITY_NOTIFICATION 0 null GL_FALSE
    glEnable GL_DEBUG_OUTPUT

locals;