porky11 / wgpu

also fix advanced wrapper and example for new wgpu API

By fabio.u.krapohl@fau.de on January 18, 2020
This patch is not signed.
BBvG7rEpRQaw9H4Bh7bcyhPZpomM6E9TBWMhZ87qWQ6Z2ceqygFb8mkVWFTt7pi7uxVrC7EJ8pMoqzP1g34FFgEh
This patch is in the following branches:
api-cleanup
master
In file README.md
30
31

32
33
* functions, that return an id are used as constructors for these new types
* destroy functions are used as destructors
* all other functions are implemented as methods of the specific types, dropping the type prefix and converting "_" to "-"
* all other functions are implemented as methods of the specific types, dropping the type prefix, or functions, when no type is applicable, while converting "_" to "-"
* functions take references instead of pointers

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
        wgpu.Surface 'xlib
using import .shaders

load-library "/usr/lib/libglfw.so.3"

import ..init

let wgpu = init

let p = pointer

define glfw
    include
        """"#include <GLFW/glfw3.h>
            #define GLFW_EXPOSE_NATIVE_X11
            #define GLFW_EXPOSE_NATIVE_WAYLAND
            #include <GLFW/glfw3native.h>

define glfw
    .. glfw.extern glfw.define

run-stage;

using glfw

let pointer = p
unlet p

let instance =
    wgpu.Instance;
fn request-adapter-callback (received userdata)
    (ptrtoref (bitcast userdata (mutable pointer wgpu.AdapterId))) = received

let adapter =
    wgpu.Adapter instance
        local wgpu.AdapterDescriptor
            power_preference = wgpu.PowerPreference.LowPower
local adapter : wgpu.Adapter 0

wgpu.request-adapter-async
    local wgpu.RequestAdapterOptions
        power_preference = wgpu.PowerPreference.LowPower
    2 | 4 | 8
    request-adapter-callback
    adapter

let device =
    wgpu.Device adapter
        local wgpu.DeviceDescriptor
            extensions =
                typeinit
                    anisotropic_filtering = false
            limits =
                typeinit
                    max_bind_groups = 1

let vertex-shader =
    wgpu.ShaderModule device
        local wgpu.ShaderModuleDescriptor
            code = vert

let fragment-shader =
    wgpu.ShaderModule device
        local wgpu.ShaderModuleDescriptor
            code = frag

local bind-group-layout =
    wgpu.BindGroupLayout device
        local wgpu.BindGroupLayoutDescriptor

let bind-group =
    wgpu.BindGroup device
        local wgpu.BindGroupDescriptor
            layout = bind-group-layout

let pipeline-layout =
    wgpu.PipelineLayout device
        local wgpu.PipelineLayoutDescriptor
            bind_group_layouts = bind-group-layout

let render-pipeline =
    wgpu.RenderPipeline device
        local wgpu.RenderPipelineDescriptor
            layout = pipeline-layout
            vertex_stage =
                wgpu.PipelineStageDescriptor
                wgpu.ProgrammableStageDescriptor
                    module = vertex-shader
                    entry_point = "main"
            fragment_stage =
                local wgpu.PipelineStageDescriptor
                local wgpu.ProgrammableStageDescriptor
                    module = fragment-shader
                    entry_point = "main"
            rasterization_state =
                wgpu.RasterizationStateDescriptor
                local wgpu.RasterizationStateDescriptor
                    front_face = wgpu.FrontFace.Ccw
In file init.sc
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
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607

608
609
610
611
612
613
614
615
616
617
618
619
620
# modifiers

inline simple (create-function)
    create-function;

inline single (create-function super)
    create-function
        'native super

inline default (create-function super desc)
    create-function
        'native super
        & ('native desc)

inline manual (create-function super desc)
    create-function super desc
inline manual (create-function super args...)
    create-function super args...

inline double (create-function super second desc)
    create-function
        'native super
        'native second
        & ('native desc)

# type definitions

sugar define-type (name unique? modifier create-function body...)
    let storage-type = (Symbol (name as Symbol as string .. "Id"))
    qq typedef [name] [unique?] (storageof [storage-type])
        let __typecall = (make-typecall this-type [modifier create-function])
        inline native (self)
            bitcast (view self) [storage-type]
        inline __imply (vT T)
            static-if (T == [storage-type])
                inline "main-type-imply" (self)
                    native self
        unquote-splice body...

sugar redef-type (typename convert-args)
    qq define [typename]
        let inner-type = [typename]
        unlet [typename]
        typedef [typename] : (storageof inner-type)
            inline __typecall (ty args...)
                let args... =
                    [convert-args] args...
                let inner-value =
                    inner-type args...
                let result =
                    bitcast inner-value this-type
                result
            inline native (self)
                bitcast self inner-type
            inline __imply (vT T)
                static-if (T == inner-type)
                    inline "descriptor-imply" (self)
                        native self

run-stage;

define main
    using native
    do
        define-type Instance : simple create_instance




        define-type Adapter : default instance_get_adapter
        define-type Device :: default adapter_request_device
        let Adapter = AdapterId
        define-type Device :: manual
            inline (super adapter)
                adapter_request_device super
                    & ('native adapter)
            inline __drop (self)
                device_destroy ('native self)
            inline poll (self force-wait)
                device_poll ('native self) force-wait

        define-type BindGroup :: default device_create_bind_group
            inline __drop (self)
                bind_group_destroy ('native self)
        define-type BindGroupLayout : default device_create_bind_group_layout

        typedef Buffer :: (storageof BufferId)
            inline __typecall (ty super desc T)
                let result rest... =
                    static-if (none? T)
                        device_create_buffer
                            'native super
                            & ('native desc)
                    else
                        local data : (mutable pointer T)
                        _
                            device_create_buffer_mapped
                                'native super
                                & ('native desc)
                                bitcast &data (mutable pointer (mutable pointer u8))
                            data
                _
                    bitcast result this-type
                    rest...
            inline native (self)
                bitcast (view self) BufferId
            inline unmap (self)
                buffer_unmap ('native self)
            inline map-read-async (self rest...)
                buffer_map_read_async ('native self) rest...
            inline map-write-async (self rest...)
                buffer_map_write_async ('native self) rest...
            inline __drop (self)
                buffer_destroy ('native self)

        define-type CommandEncoder : default device_create_command_encoder
            inline copy-buffer-to-buffer (self src src_offset dst dst_offset size)
                command_buffer_copy_buffer_to_buffer
                command_encoder_copy_buffer_to_buffer
                    'native self
                    'native src
                    src_offset
                    'native dst
                    dst_offset
                    size

            inline make-copy (method)
                inline "copier" (self source destination copy_size)
                    method
                        'native self
                        reftoptr source
                        reftoptr destination
                        copy_size
            let copy-buffer-to-texture copy-texture-to-buffer copy-texture-to-texture =
                va-map make-copy
                    command_buffer_copy_buffer_to_texture
                    command_buffer_copy_texture_to_buffer
                    command_buffer_copy_texture_to_texture
                    command_encoder_copy_buffer_to_texture
                    command_encoder_copy_texture_to_buffer
                    command_encoder_copy_texture_to_texture
            unlet make-copy
            
        define-type ComputePipeline : default device_create_compute_pipeline
        define-type PipelineLayout : default device_create_pipeline_layout
        define-type RenderPipeline : default device_create_render_pipeline
        unlet Sampler; define-type Sampler : default device_create_sampler
        define-type ShaderModule : default device_create_shader_module
        define-type SwapChain : double device_create_swap_chain
            inline present (self)
                swap_chain_present
                    'native self

        define-type Texture :: default device_create_texture
            inline __drop (self)
                texture_destroy ('native self)
        define-type TextureView :: manual
            inline (super desc)
            inline (super desc)
            inline (super desc)
                static-if (none? desc)
                    texture_create_default_view
                        'native super
                else
                    texture_create_view
                        'native super
                        & ('native desc)
        define-type TextureView :: default texture_create_view
            inline __drop (self)
                texture_view_destroy ('native self)

        define-type ComputePass : single command_encoder_begin_compute_pass
            inline set-pipeline (self pipeline)
                compute_pass_set_pipeline
                    'native self
                    'native pipeline
            inline set-bind-group (self index bind-group offsets)
                compute_pass_set_bind_group ('native self) index
                    'native bind-group
                    to-pointer-count offsets
            
            inline dispatch (self args...)
                compute_pass_dispatch ('native self) args...

            inline insert-debug-marker (self label)
                compute_pass_insert_debug_marker
                    'native self
                    label as rawstring

            inline pop-debug-group (self)
                compute_pass_pop_debug_group
                    'native self


            inline push-debug-group (self label)
                compute_pass_push_debug_group
                    'native self
                    label as rawstring

            inline end-pass (self)
                compute_pass_end_pass
                    'native self
                ;

        define-type RenderPass : default command_encoder_begin_render_pass
            inline set-pipeline (self pipeline)
                render_pass_set_pipeline
                    'native self
                    'native pipeline
            inline set-bind-group (self index bind-group offsets)
                render_pass_set_bind_group
                    'native self
                    index
                    'native bind-group
                    to-pointer-count offsets
            
            inline insert-debug-marker (self label)
                render_pass_insert_debug_marker
                    'native self
                    label as rawstring

            inline pop-debug-group (self)
                render_pass_pop_debug_group
                    'native self


            inline push-debug-group (self label)
                render_pass_push_debug_group
                    'native self
                    label as rawstring

            inline set-blend-color (self color)
                render_pass_set_blend_color
                    'native self
                    label as rawstring
                
            inline set-index-buffer (self buffer offset)
                render_pass_set_index_buffer
                    'native self
                    'native buffer
                    offset

            inline set-scissor-rect (self args...)
                render_pass_set_scissor_rect
                    'native self
                    args...

            inline set-stencil-reference (self args...)
                render_pass_set_stencil_reference
                    'native self
                    args...

            #void wgpu_render_pass_set_vertex_buffers(WGPURenderPassId pass_id,
                                             const WGPUBufferId *buffer_ptr,
                                             const WGPUBufferAddress *offset_ptr,
                                             uintptr_t count);

            inline set-viewport (self args...)
                
                render_pass_set_viewport
                    'native self
                    args...

            inline draw (self args...)
                render_pass_draw ('native self) args...

            inline draw-indexed (self args...)
                render_pass_draw_indexed ('native self) args...

            inline draw-indirect (self args...)
                render_pass_draw_indirect ('native self) args...

            inline draw-indexed-indirect (self args...)
                render_pass_draw_indexed_indirect ('native self) args...

            inline end-pass (self)
                render_pass_end_pass
                    'native self
                ;


        typedef Surface : (storageof SurfaceId)
            inline __typecall (ty instance kind args...)
            inline __typecall (ty kind args...)
                bitcast
                    call
                        static-match kind
                        case 'xlib
                            instance_create_surface_from_xlib
                            create_surface_from_xlib
                        case 'windows-hwnd
                            instance_create_surface_from_windows_hwnd
                            create_surface_from_windows_hwnd
                        case 'macos-layer
                            instance_create_surface_from_macos_layer
                            create_surface_from_metal_layer
                        default
                            static-error "Window backend not supported"
                        'native instance
                        args...
                    this-type

            inline native (self)
                bitcast (view self) SurfaceId

        typedef CommandBuffer : (storageof CommandBufferId)
            inline __typecall (ty super)
            inline __typecall (ty super arg)
                bitcast
                    static-match (typeof super)
                    case CommandEncoder
                        command_encoder_finish ('native super)
                            static-if (none? arg)
                                null
                            else
                                reftoptr arg
                    default
                        static-error
                            "CommandBuffer cannot be created from this type" .. (tostring (typeof super))
                    this-type
            inline native (self)
                bitcast (view self) CommandBufferId

            inline copy-buffer-to-buffer (self src src_offset dst dst_offset size)
                command_buffer_copy_buffer_to_buffer
                command_encoder_copy_buffer_to_buffer
                    'native self
                    'native src
                    src_offset
                    'native dst
                    dst_offset
                    size

            inline make-copy (method)
                inline "copier" (self source destination copy_size)
                    method
                        'native self
                        reftoptr source
                        reftoptr destination
                        copy_size
            let copy-buffer-to-texture copy-texture-to-buffer copy-texture-to-texture =
                va-map make-copy
                    command_buffer_copy_buffer_to_texture
                    command_buffer_copy_texture_to_buffer
                    command_buffer_copy_texture_to_texture
                    command_encoder_copy_buffer_to_texture
                    command_encoder_copy_texture_to_buffer
                    command_encoder_copy_texture_to_texture
            unlet make-copy

        define-type Queue : single device_get_queue
            inline submit (self command-buffers)
                queue_submit
                    'native self
                    static-if ((typeof command-buffers) == CommandBuffer)
                        _ (bitcast &command-buffers (pointer CommandBufferId)) 1
                    else
                        let ptr count =
                            to-pointer-count command-buffers
                        _ (bitcast ptr (pointer CommandBufferId)) count
        locals;

define descriptors
    inline id (args...) args...

    using native
    do
        redef-type AdapterDescriptor id
        redef-type RequestAdapterOptions id
        redef-type DeviceDescriptor id
        redef-type BlendDescriptor id
        redef-type BufferDescriptor id
        redef-type ColorStateDescriptor id
        redef-type CommandEncoderDescriptor id
        redef-type DepthStencilStateDescriptor id
        redef-type RasterizationStateDescriptor id
        redef-type RenderPassColorAttachmentDescriptor id
        redef-type SamplerDescriptor id
        redef-type ShaderModuleDescriptor id
        redef-type StencilStateFaceDescriptor id
        redef-type SwapChainDescriptor id
        redef-type TextureDescriptor id
        redef-type TextureViewDescriptor id
        let VertexAttributeDescriptor_native = VertexAttributeDescriptor
        redef-type VertexAttributeDescriptor id
        let VertexBufferDescriptor_native = VertexBufferDescriptor
        redef-type VertexBufferDescriptor
            inline (stride step_mode attributes)
                let attributes attributes_length =
                    static-if ((typeof attributes) == VertexAttributeDescriptor)
                        _ (reftoptr ('native attributes)) 1
                    else
                        let ptr count =
                            to-pointer-count attributes
                        _ (bitcast ptr (pointer VertexAttributeDescriptor_native)) count
                keyed stride step_mode attributes attributes_length

        redef-type BindGroupLayoutDescriptor
            inline (bindings)
                static-if ((typeof bindings) == BindGroupLayoutBinding)
                    _ &bindings 1
                else
                    to-pointer-count bindings
            
        redef-type PipelineLayoutDescriptor
            inline (bind_group_layouts)
                static-if ((typeof bind_group_layouts) == main.BindGroupLayout)
                    _ (reftoptr ('native bind_group_layouts)) 1
                else
                    let ptr count =
                        to-pointer-count bind_group_layouts
                    _ (bitcast ptr (pointer BindGroupLayoutId)) count

        redef-type RenderPipelineDescriptor
            inline (layout color_states color_states_length vertex_stage fragment_stage rasterization_state depth_stencil_state rest...)
                static-assert (none? color_states_length) "Length not supported. Use an array type instead."
                let color_states color_states_length =
                    do
                        let ptr count =
                            static-if ((typeof color_states) == ColorStateDescriptor)
                                _
                                    reftoptr color_states
                                    1
                            else
                                to-pointer-count color_states
                        let ptr =
                            bitcast ptr (pointer native.ColorStateDescriptor)
                        _ ptr count
                _
                    layout =
                        'native layout
                    vertex_stage =
                        'native vertex_stage
                    fragment_stage =
                        reftoptr
                            'native fragment_stage
                    rasterization_state =
                        'native rasterization_state
                        reftoptr
                            'native rasterization_state
                    color_states = color_states
                    color_states_length = color_states_length
                    depth_stencil_state =
                        reftoptr
                            'native depth_stencil_state
                    rest...

        redef-type ComputePipelineDescriptor
            inline (layout rest...)
                _
                    layout =
                        'native layout
                    rest...

        redef-type PipelineStageDescriptor
        redef-type ProgrammableStageDescriptor
            inline (module rest...)
                _
                    module =
                        'native module
                    rest...

        redef-type VertexInputDescriptor
            inline (vertex_buffers rest...)
                _
                    call
                        va-join
                            static-if ((typeof vertex_buffers) == VertexBufferDescriptor)
                                _ 
                                    vertex_buffers = (reftoptr ('native vertex_buffers))
                                    vertex_buffers_length = 1
                            else
                                let ptr count =
                                    to-pointer-count vertex_buffers
                                _
                                    vertex_buffers = (bitcast ptr (pointer VertexBufferDescriptor_native))
                                    vertex_buffers_length = count
                        rest...

        redef-type RenderPassDescriptor
            inline (color_attachments depth_stencil_attachment)
                _
                    call
                        va-join
                            do
                                let ptr count =
                                    static-if ((typeof color_attachments) == RenderPassColorAttachmentDescriptor)
                                        _
                                            reftoptr color_attachments
                                            color_attachments_length = 1
                                    else
                                        to-pointer-count color_attachments
                                let ptr =
                                    bitcast ptr (pointer native.RenderPassColorAttachmentDescriptor)
                                _
                                    color_attachments = ptr
                                    color_attachments_length = count
                        depth_stencil_attachment = &depth_stencil_attachment
        locals;


define used
    using native
    do
        let
            BindGroupLayoutBinding
            BufferAddress
            BufferCopyView
            Extent3d
            Limits
            Origin3d
            ShaderLocation
            TextureCopyView
            PresentMode
        
        let # simple enums
            AddressMode
            BindingType
            BlendFactor
            BlendOperation
            BufferMapAsyncStatus
            CompareFunction
            CullMode
            FilterMode
            FrontFace
            IndexFormat
            InputStepMode
            LoadOp
            PowerPreference
            PrimitiveTopology
            StencilOperation
            StoreOp
            TextureDimension
            TextureFormat
            TextureViewDimension
            VertexFormat
    
        let ShaderStage BufferUsage TextureUsage ColorWrite TextureAspectFlags

        let Color

        let U32Array
        typedef+ U32Array
            # this is allowed, since this method didn't exist before
            inline __rimply (vT T)
                static-if (vT == string)
                    inline "U32Array-rimply" (self)
                        U32Array
                            bitcast (self as rawstring) (pointer u32)
                            (countof self) // 4
        let SwapChainOutput
        typedef+ SwapChainOutput
            # this is allowed, since the struct is never created this way when using the native wrapper
            let __typecall = (make-typecall this-type single native.swap_chain_get_next_texture)
        

        # device descriptor
        let
            Extensions
            Limits

        locals;

define redef
    using native
    do
        redef-type BufferBinding
            inline (buffer rest...)
                _
                    buffer =
                        'native buffer
                    rest...

        redef-type BindGroupBinding
            inline (binding resource)
                _
                    binding = binding
                    resource =
                        'native resource

        redef-type BindGroupDescriptor
            inline (layout bindings)
                _
                    layout =
                        'native layout
                    do
                        let ptr count =
                            static-if ((typeof bindings) == BindGroupBinding)
                                _ &bindings 1
                            else
                                to-pointer-count bindings
                        let ptr =
                            bitcast ptr (pointer native.BindGroupBinding)
                        _
                            bindings = ptr
                            bindings_length = count
        locals;

define special
    let inner-type = native.BindingResource
    typedef BindingResource : (storageof inner-type)
        inline... create
        case (buffer-binding : redef.BufferBinding,)
            native.buffer_binding_create_resource
                & ('native buffer-binding)
        case (sampler : main.Sampler,)
            native.sampler_create_resource
                'native sampler
        case (texture-view : main.TextureView,)
            native.texture_view_create_resource
                'native texture-view

        inline __typecall (ty args...)
            let result =
                create args...
            bitcast result this-type
        unlet create

        inline native (self)
            bitcast self inner-type
        inline __imply (vT T)
            static-if (T == inner-type)
                inline "descriptor-imply" (self)
                    native self
    locals;

.. main descriptors used redef special
define functions
    using native
    inline request-adapter-async (desc mask callback userdata)
        request_adapter_async
            reftoptr
                'native desc
            mask
            static-typify callback AdapterId voidstar
            &userdata
    locals;

.. main descriptors used redef special functions