wasmlike.rkt 29.4 KB
Newer Older
Guy Watson's avatar
Guy Watson committed
1
#lang xsmith/private/base 
Guy Watson's avatar
Guy Watson committed
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
;; -*- mode: Racket -*-
;;
;; Copyright (c) 2019 The University of Utah
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are met:
;;
;;   * Redistributions of source code must retain the above copyright notice,
;;     this list of conditions and the following disclaimer.
;;
;;   * Redistributions in binary form must reproduce the above copyright
;;     notice, this list of conditions and the following disclaimer in the
;;     documentation and/or other materials provided with the distribution.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;; ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;; POSSIBILITY OF SUCH DAMAGE.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

31
32
(require
  xsmith
33
  xsmith/racr-convenience
34
  xsmith/app
35
  racr
36
  racket/class
37
38
  racket/pretty
  racket/string
39
  racket/match
40
  (except-in racket/list empty))
41
 
42
(define-spec-component wasm-like)
43

44
45
46
(define (choose-random-sign) (< (random) 0.5))
;;todo use a passed in node to assign sign distributions per type instead of blanket-wise

47
48
;; This defines the layout of the grammar.
(add-to-grammar
49
 wasm-like
50
 [Program #f (Func
51
               ;;[main : Func]
52
              [globals : GlobalDeclaration *])]
53
54
 [Func #f ([root : Expr]
           [localcount = (random 1 10)])]
55
56
 [Expr #f ()
       #:prop may-be-generated #f]
57
 [Literal Expr ()
58
          #:prop choice-weight 3 ;; default is 10
59
60
          #:prop may-be-generated #f]
 [LiteralIntThirtyTwo Literal ([v = (random -1000 1000)]) ;;todo add command line feature for the whole range
61
                      #:prop choice-weight 3]
62
 [LiteralIntSixtyFour Literal ([v = (random -1000 1000)])
63
                      #:prop choice-weight 3]
64
 [LiteralFloatThirtyTwo Literal ([v = (+ (random -1000 1000) (random))])
65
                        #:prop choice-weight 3]
66
 [LiteralFloatSixtyFour Literal ([v = (+ (random -1000 1000) (random))])
67
                        #:prop choice-weight 3]
68

69
 [Noop Expr ([expr : Expr])]
70
71
72
73
74
75
76
77
78
79
 [Binop Expr ([l : Expr] [r : Expr]) ;;Binops take a left and a right and produce the same type
        #:prop choice-weight 30      ;; as the result
        #:prop may-be-generated #f]
 [Comparison Expr ([l : Expr] [r : Expr]) ;;Comparisons take a left and a right of the same type
             #:prop choice-weight 20      ;; but return a boolean, which is always an i32
             #:prop may-be-generated #f]  ;; Section 2.4.1 in the spec has more detail
 [Unop Expr ([expr : Expr]) ;;Unops take one operand and return a value of that type 
       #:prop choice-weight 20
       #:prop may-be-generated #f]
 [Testop Expr ([expr : Expr]) ;;Testops take one operand but return a boolean (i32)
80
         #:prop choice-weight 50
81
         #:prop may-be-generated #f]
82

83
84
 [Addition Binop ()
           #:prop choice-weight 50]
Guy Watson's avatar
Guy Watson committed
85
86
 [Subtraction Binop ()]
 [Multiplication Binop ()]
87
88
 [Division Binop ([sign = (choose-random-sign)])] ;;These signs only matter for ints, not floats
 [Remainder Binop ([sign = (choose-random-sign)])]
Guy Watson's avatar
Guy Watson committed
89
90
91
 [And Binop ()]
 [Or Binop ()]
 [Xor Binop ()]
92
 [ShiftLeft Binop ()]
93
 [ShiftRight Binop ([sign = (choose-random-sign)])]
94
95
 [RotateLeft Binop ()]
 [RotateRight Binop ()]
96
97
98
99
100
101
102
103
104
105
106
107
 [Min Binop ()]
 [Max Binop ()]
 [CopySign Binop ()]

 
 [Equal Comparison ()]
 [NotEqual Comparison ()]
 [LessThan Comparison ([sign = (choose-random-sign)])]
 [GreaterThan Comparison ([sign = (choose-random-sign)])]
 [LessThanOrEqual Comparison ([sign = (choose-random-sign)])]
 [GreaterThanOrEqual Comparison ([sign = (choose-random-sign)])]

108
 [CountLeadingZero Unop ()]  ;; According to the spec, these are unops, not testops
Guy Watson's avatar
Guy Watson committed
109
110
 [CountTrailingZero Unop ()]
 [NonZeroBits Unop ()]
111
112
113
114
115
116
117
118
119
120
 [AbsoluteValue Unop ()]
 [Negate Unop ()]
 [SquareRoot Unop ()]
 [Ceiling Unop ()]
 [Floor Unop ()]
 [Truncate Unop ()]
 [Nearest Unop ()]

 [EqualZero Testop ()]
 
Guy Watson's avatar
Guy Watson committed
121
122
123
 [IfElse Expr ([cond : Expr]
               [then : Expr]
               [else : Expr])
124
         #:prop choice-weight 10]
125
126
 [If Expr ([cond : Expr]
           [then : Expr])]
127
128
 [Block Expr ([expr : Expr])]
 [Loop Expr ([expr : Expr])]
129
130
131
 [Branch Expr ([val : Expr]
               [targetnode]
               [targetindex]) ;; a number depth
Guy Watson's avatar
Guy Watson committed
132
         ;; todo: the type of val should be unified with the target node
133
         #:prop choice-weight 10]
Guy Watson's avatar
Guy Watson committed
134
135
136
137
 [BranchIf Expr ([cond : Expr]
                 [val : Expr]
                 [targetnode]
                 [targetindex])
138
           #:prop choice-weight 10]
139
 [MemStore Expr ([address : LiteralIntThirtyTwo]
140
141
142
143
                 [value : Expr]
                 [offset = (abs (- (random 20000) 10000))] ;; This probably has some bias towards 0
                 [alignment = (random 4)]
                 [expr : Expr])
144
           #:prop choice-weight 3]
145
 [MemLoad Expr ([address : LiteralIntThirtyTwo]
146
147
                [offset = (abs (- (random 20000) 10000))]
                [alignment = (random 4)])
148
           #:prop choice-weight 3]
149
150
 [LocalGet Expr ([index])
           #:prop choice-weight 0] ;;todo Change these over to the xsmith reference system once random reference increases are implemented by William
151
 [LocalSet Expr ([val : Expr]
152
                 [index]
153
154
                 [expr : Expr])
           #:prop choice-weight 0]
Guy Watson's avatar
Guy Watson committed
155
 [LocalTee Expr ([val : Expr]
156
157
                 [index])
           #:prop choice-weight 0]
158
159
 [GlobalDeclaration #f ([name]
                        [type]
160
                        [initialvalue : Literal])
161
162
                    #:prop binder-info (name type definition)]
 [GlobalGet Expr ([name])
163
            #:prop reference-info (read name)
164
            #:prop choice-weight 4] 
165
 [GlobalSet Expr ([val : Expr]
166
167
                  [name])
            #:prop reference-info (write name)
168
            #:prop choice-weight 4]
169

170
171
172
173
 ;; Type conversions
 [TypeConversion Expr ([expr : Expr])
                 #:prop choice-weight 20
                 #:prop may-be-generated #f]
174
 [TruncateFloat TypeConversion ([sign = (choose-random-sign)])]  ;; float -> int
175
176
177
178
179
 [ConvertInt TypeConversion ([sign = (choose-random-sign)])]     ;; int -> float
 [Wrap TypeConversion ()]                                        ;; i64 -> i32
 [Extend TypeConversion ([sign = (choose-random-sign)])]         ;; i32 -> i64
 [Demote TypeConversion ()]                                      ;; f64 -> f32
 [Promote TypeConversion ()]                                     ;; f32 -> f64
180
181
182
183
 [ReinterpretIntThirtyTwo TypeConversion ()]
 [ReinterpretIntSixtyFour TypeConversion ()]
 [ReinterpretFloatThirtyTwo TypeConversion ()]
 [ReinterpretFloatSixtyFour TypeConversion ()]
184
185


186
 ;; Idiomatic Generation
187
188
189
 [ForLoop Expr ([initial : Literal]
                [loopvar : GlobalSet]
                [loopbody : Expr])
Guy Watson's avatar
Guy Watson committed
190
          #:prop choice-weight 30]
191
 
192
193
194
195
196
 )

(add-prop
  wasm-like
  fresh
Guy Watson's avatar
Guy Watson committed
197
198
199
200
201
202
203
204
205
206
207
  [Branch (if (ast-has-parent? current-hole) ;; Only check for targets if we are attached to the tree
                                             ;; For example: generating a branch instruction for the
                                             ;; for loop below while not connected to the tree. We
                                             ;; must manually specify the target
            (match-let ([(cons index node) (choose-br-target (current-hole))])
              (hash 'targetindex index 'targettype (node-type node)))
            (hash))]
  [BranchIf (if (ast-has-parent? current-hole)
              (match-let ([(cons index node) (choose-br-target (current-hole))])
                (hash 'targetindex index 'targettype (node-type node)))
              (hash))]
208
209
  [LocalGet (hash 'index (choose-local-target (current-hole)))]
  [LocalSet (hash 'index (choose-local-target (current-hole)))]
Guy Watson's avatar
Guy Watson committed
210
  [LocalTee (hash 'index (choose-local-target (current-hole)))]
211
212
213

  #;[GlobalGet (hash 'name (fresh-var-name "$global_"))]
  #;[GlobalSet (hash 'name (fresh-var-name "$global_"))]
214
215
  ;;todo Implement these with the upcoming custom name changes  
 
216
  ;; Let the initial value and loop body be handled by the default
217
218
219
  [ForLoop (hash 'loopvar (make-fresh-node 
                            'GlobalSet
                            (hash 'val (make-fresh-node 'LiteralIntThirtyTwo) ;;dummy
220
                                  'name (binding-name (send this xsmith_get-reference-for-child! i32 #t)))))]
221
222
223
224
225
226
227
228
229
230
231
)

(add-att-rule
  wasm-like
  nesting-level
  [Program (λ (n c) 0)]
  [IfElse (λ (n c)
             (let ([depth (att-value 'nesting-level (ast-parent n) n)])
               (if (eq? c (ast-child 'cond n))
                   (+ 0 depth)
                   (+ 1 depth))))]
232
  [Func (λ (n c) (+ 1 (att-value 'nesting-level (ast-parent n))))])
233

234
;; All the base types of WebAssembly
235
236
237
238
(define i32 (base-type 'i32))
(define i64 (base-type 'i64))
(define f32 (base-type 'f32))
(define f64 (base-type 'f64))
239
;; Larger groups - use when ALL the contained types are valid
240
241
242
(define (fresh-number) (fresh-type-variable i32 i64 f32 f64))
(define (fresh-int) (fresh-type-variable i32 i64))
(define (fresh-float) (fresh-type-variable f32 f64))
243

244
(define (no-child-types)
245
246
  (λ (n t)
     (hash)))
247

248
(define (binop-rhs) (λ (n t)
249
250
                       (hash 'l t
                             'r t)))
251
252
(define (unop-rhs) (λ (n t)
                      (hash 'expr t)))
253

254
255
(add-prop
 wasm-like type-info
256
          [Program [i32
257
                    (λ (n t) 
258
                       (hash 'Func i32
259
260
                             'globals (λ (child-node) (fresh-number))))]]
          [GlobalDeclaration [(fresh-number)
261
                               (λ (n t) (hash 'initialvalue t))]]
262
          [Func [(fresh-number) 
263
264
                 (λ (n t)
                    (hash 'root t))]]
265
          [LiteralIntThirtyTwo [i32
266
                                 (no-child-types)]]
267
          [LiteralIntSixtyFour [i64
268
                                 (no-child-types)]]
269
          [LiteralFloatThirtyTwo [f32
270
                                   (no-child-types)]]
271
          [LiteralFloatSixtyFour [f64
272
                                   (no-child-types)]]
273
          [Noop [(fresh-number) (λ (n t) (hash 'expr t))]] ;;todo This is wierd....
274
          
275
          [Binop [(fresh-number) (binop-rhs)]]
276
          ;; Restricted binops:
277
278
279
280
281
282
283
284
285
286
287
          [Remainder [(fresh-int) (binop-rhs)]]
          [And [(fresh-int) (binop-rhs)]]
          [Or [(fresh-int) (binop-rhs)]]
          [Xor [(fresh-int) (binop-rhs)]]
          [ShiftLeft [(fresh-int) (binop-rhs)]]
          [ShiftRight [(fresh-int) (binop-rhs)]]
          [RotateLeft [(fresh-int) (binop-rhs)]]
          [RotateRight [(fresh-int) (binop-rhs)]]
          [Min [(fresh-float) (binop-rhs)]]
          [Max [(fresh-float) (binop-rhs)]]
          [CopySign [(fresh-float) (binop-rhs)]]
288

289
          [Unop [(fresh-number) (unop-rhs)]]
290
          ;; Restricted Unops
291
292
293
294
295
296
297
298
299
300
          [CountLeadingZero [(fresh-int) (unop-rhs)]]
          [CountTrailingZero [(fresh-int) (unop-rhs)]]
          [NonZeroBits [(fresh-int) (unop-rhs)]]
          [AbsoluteValue [(fresh-float) (unop-rhs)]]
          [Negate [(fresh-float) (unop-rhs)]]
          [SquareRoot [(fresh-float) (unop-rhs)]]
          [Ceiling [(fresh-float) (unop-rhs)]]
          [Floor [(fresh-float) (unop-rhs)]]
          [Truncate [(fresh-float) (unop-rhs)]]
          [Nearest [(fresh-float) (unop-rhs)]]
301
          
302
          [Comparison [i32
303
304
305
306
                        (λ (n t) ;; The type of the children is unconstrained, they just have to be the same
                           (define child-type (fresh-number)) 
                           (hash 'l child-type
                                 'r child-type))]]
307
308
          [Testop [i32
                    (λ (n t) ;; The only testop in wasm 1.1 is integer only
309
310
                       (hash 'expr (fresh-int)))]]
          [IfElse [(fresh-number)
311
                    (λ (n t)
312
313
314
                     (hash 'cond i32
                           'then t
                           'else t))]]
315
          [If [(fresh-number)
316
                (λ (n t)
317
318
                   (hash 'cond i32
                         'then t))]]
319
320


321
322
323
          [Block [(fresh-number) (λ (n t) (hash 'expr t))]]
          [Loop [(fresh-number) (λ (n t) (hash 'expr t))]]
          [ForLoop [(fresh-number) (λ (n t) (hash 'initial i32
324
325
                                            'loopvar i32
                                            'loopbody t))]]
326
327
          [Branch [(fresh-number) (λ (n t) (hash 'val t))]] ;;todo triple check branch interactions here
          [BranchIf [(fresh-number) 
328
329
                     (λ (n t) (hash 'cond i32
                                    'val t))]]
330
          [MemStore [(fresh-number)
331
332
333
                     (λ (n t) (hash 'address i32 
                                    'value t
                                    'expr t))]]
334
          [MemLoad [(fresh-number) (λ (n t) (hash 'address i32))]]
335
          [LocalGet [i32 (no-child-types)]] ;;todo change to the new reference binding system
336
337
338
          [LocalSet [i32 (λ (n t) (hash 'val i32
                                        'expr i32))]]
          [LocalTee [i32 (λ (n t) (hash 'val i32))]]
339
340
          [GlobalGet [(fresh-number) (no-child-types)]]
          [GlobalSet [(fresh-number) (λ (n t) (hash 'val t))]]
341
          ;;Type conversions
342
          [TruncateFloat [(fresh-int) 
343
                     (λ (n t) 
344
345
                        (hash 'expr (fresh-float)))]]
          [ConvertInt [(fresh-float) 
346
                    (λ (n t) 
347
                       (hash 'expr (fresh-int)))]]
348
349
350
351
352
353
354
355
          [Wrap [i32 (λ (n t) 
                        (hash 'expr i64))]]
          [Extend [i64 (λ (n t)
                          (hash 'expr i32))]]
          [Demote [f32 (λ (n t)
                          (hash 'expr f64))]]
          [Promote [f64 (λ (n t)
                          (hash 'expr f32))]]
356
357
358
359
360
361
362
363
          [ReinterpretIntThirtyTwo [f32 (λ (n t)
                                           (hash 'expr i32))]]
          [ReinterpretIntSixtyFour [f64 (λ (n t)
                                           (hash 'expr i64))]]
          [ReinterpretFloatThirtyTwo [i32 (λ (n t)
                                           (hash 'expr f32))]]
          [ReinterpretFloatSixtyFour [i64 (λ (n t)
                                           (hash 'expr f64))]]
Guy Watson's avatar
Guy Watson committed
364
)
365

366
;; Define structured control instruction property
Guy Watson's avatar
Guy Watson committed
367
(define-non-inheriting-rule-property
368
369
  structured-control-instruction
  att-rule
370
  #:default (λ (n) #f)
371
  )
372

Guy Watson's avatar
Guy Watson committed
373
(add-prop
374
375
 wasm-like
 structured-control-instruction
376
377
 [Func (λ (n) #t)]
 [IfElse (λ (n) #t)]
378
379
 [If (λ (n) #t)]
 [Block (λ (n) #t)]
380
 [Loop (λ (n) #t)])
381

382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
(define (get-nesting-types node)
  (let ([type (node-type node)])
    (if (eq? type 'Func)
      (list type)
      (if (att-value 'structured-control-instruction node)
        (cons type (get-nesting-types (parent-node node)))
        (get-nesting-types (parent-node node))))))

;; gets an ancestry trace up the tree
(define (get-parents n)
  (if (parent-node n)
    (cons n (get-parents (parent-node n)))
    (list n)))

;; converts a list of nodes into a list of their names (for debugging)
(define (node-names l)
  (map (λ (n) (node-type n))
       l))

401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
(define (valid-br-targets ns)
  (filter values
          (for/list ([child ns]
                     [parent (rest ns)])
            (if (and (att-value 'structured-control-instruction parent)
                     (att-value 'control-valid? parent child))
              parent
              #f))))

(add-att-rule
  wasm-like
  control-valid?
  [#f (λ (n c) #t)]
  [IfElse (λ (n c)
             (not (eq? (ast-child 'cond n) c)))]
416
417
  [If (λ (n c)
         (not (eq? (ast-child 'cond n) c)))]
418
419
  [ForLoop (λ (n c)
              (not (eq? (ast-child 'loopvar n) c)))]
420
  )
421

Guy Watson's avatar
Guy Watson committed
422
423
424
425
426

(define (choose-br-target n)
  (let* ([parents (get-parents n)]
         [targets (valid-br-targets parents)]
         [index (random (length targets))])
427
    (cons index (list-ref targets index))))
Guy Watson's avatar
Guy Watson committed
428

429
430
431
432
433
434
(define (get-func-node n)
  (if (eq? (node-type n) 'Func)
    n
    (get-func-node (parent-node n))))

(define (choose-local-target n)
435
  (random (ast-child 'localcount (get-func-node n))))
436

437
;; Convenience function for getting the name of the type
438
439
;; This function is only used in the renderer, so it will concretize
;; the type and return its name as a symbol
440
(define (get-base-type-name n)
441
  (base-type-name (concretize-type (att-value 'xsmith_type n))))
442

443
444
445
446
447
448
449
450
;; Combines an node's base type and a given string. Returns a symbol.
;; This is useful for constructing symbols like i32.add
;; Usage: (prefix-type <some node> ".add")
;; Return: 'i32.add
(define (prefix-type node instruction)
  (let ([type (get-base-type-name node)])
    (string->symbol (format "~a~a" type instruction))))
         
Guy Watson's avatar
Guy Watson committed
451

Guy Watson's avatar
Guy Watson committed
452
453
454
(add-prop
 wasm-like
 render-node-info
455
 [Program (λ (n) `(module
456
457
                    (import "env" "memory" (memory $mem 1))
                    (import "env" "addToCrc" (func $addToCrc (param i32)))
458
                    (import "env" "__memory_base" (global $mem_base i32))
459
                    ,@(map (λ (global)
460
                             `(global ,(string->symbol (format "$~a" (ast-child 'name global))) 
461
                                      (mut ,(get-base-type-name global))
462
                                      ,($xsmith_render-node (ast-child 'initialvalue global))))
463
                        (reverse (ast-children (ast-child 'globals n))))
464
                    ,($xsmith_render-node (ast-child 'Func n))
465
466
                    (global $mem_base_internal (mut i32) (i32.const 0))
                    (global $mem_max_internal (mut i32) (i32.const 0))
467
                    (func (export "__post_instantiate")
468
469
470
                          global.get $mem_base
                          global.set $mem_base_internal
                          global.get $mem_base_internal
471
472
                          i32.const 5242880
                          i32.add
473
                          global.set $mem_max_internal)
Guy Watson's avatar
Guy Watson committed
474
                    (func (export "_crc_globals")
475
476
477
478
479
                       ,@(flatten (map (λ (global) (append
                                                    '(global.get)
                                                    (list (string->symbol (format "$~a" (ast-child 'name global))))
                                                    '(call $addToCrc)))
                              (reverse (ast-children (ast-child 'globals n))))))))]
480
 [Func (λ (n) `(func (export "_func") (result i32)
481
                      (local ,@(make-list (ast-child 'localcount n) 'i32)) ;;todo convert to new method
482
                     ,@($xsmith_render-node (ast-child 'root n))))]
Guy Watson's avatar
Guy Watson committed
483
484
485
486
 [LiteralIntThirtyTwo (λ (n) (list 'i32.const (ast-child 'v n)))]
 [LiteralIntSixtyFour (λ (n) (list 'i64.const (ast-child 'v n)))]
 [LiteralFloatThirtyTwo (λ (n) (list 'f32.const (ast-child 'v n)))]
 [LiteralFloatSixtyFour (λ (n) (list 'f64.const (ast-child 'v n)))]
Guy Watson's avatar
Guy Watson committed
487
488
 [Noop (λ (n) (append
                 '(nop)
489
                 ($xsmith_render-node (ast-child 'expr n))))]
490
 [Binop (λ (n) (append 
491
492
                  ($xsmith_render-node (ast-child 'l n))
                  ($xsmith_render-node (ast-child 'r n))
493
                  (list (att-value 'math-op n))))]
494
 [Unop (λ (n) (append
495
                 ($xsmith_render-node (ast-child 'expr n))
496
                 (list (att-value 'math-op n))))]
497
498
499
500
501
502
503
 [Comparison (λ (n) (append
                       ($xsmith_render-node (ast-child 'l n))
                       ($xsmith_render-node (ast-child 'r n))
                       (list (att-value 'math-op n))))]
 [Testop (λ (n) (append
                   ($xsmith_render-node (ast-child 'expr n))
                   (list (att-value 'math-op n))))]
Guy Watson's avatar
Guy Watson committed
504
 [IfElse (λ (n)           
505
           (append
506
                ($xsmith_render-node (ast-child 'cond n))
507
                `(if (result ,(get-base-type-name n)))
508
                ($xsmith_render-node (ast-child 'then n))
509
                '(else)
510
                ($xsmith_render-node (ast-child 'else n))
511
                '(end)))]
512
513
 [If (λ (n)
        (append
514
          ($xsmith_render-node (ast-child 'cond n))
515
          `(if (result ,(get-base-type-name n)))
516
          ($xsmith_render-node (ast-child 'then n))
517
518
519
          '(end)))]
 [Block (λ (n)
           (append
520
             `(block (result ,(get-base-type-name n)))
521
             ($xsmith_render-node (ast-child 'expr n))
522
523
524
             '(end)))]
 [Loop (λ (n)
          (append
525
            `(loop (result ,(get-base-type-name n)))
526
            ($xsmith_render-node (ast-child 'expr n))
527
            '(end)))]
528

529
530
 [ForLoop (λ (n)
             (append
531
532
                 ($xsmith_render-node (ast-child 'initial n))
                 `(global.set ,(string->symbol (format "$~a" (ast-child 'name (ast-child 'loopvar n)))))
533
                 `(loop (result ,(get-base-type-name n)))
534
535
536
                 `(global.get ,(string->symbol (format "$~a" (ast-child 'name (ast-child 'loopvar n)))))
                 '(i32.const 1)
                 '(i32.sub)
537
                 `(global.set ,(string->symbol (format "$~a" (ast-child 'name (ast-child 'loopvar n)))))
538
539
540
541
542
543
                 ;; loop body here
                 ($xsmith_render-node (ast-child 'loopbody n))
                 `(global.get ,(string->symbol (format "$~a" (ast-child 'name (ast-child 'loopvar n)))))
                 '(i32.const 0)
                 '(i32.ge_s)
                 '(br_if 0)))]
Guy Watson's avatar
Guy Watson committed
544
545
 [Branch (λ (n)
            (append
546
              ($xsmith_render-node (ast-child 'val n))
Guy Watson's avatar
Guy Watson committed
547
              `(br ,(ast-child 'targetindex n))))]
Guy Watson's avatar
Guy Watson committed
548
549
 [BranchIf (λ (n)
              (append
550
551
                ($xsmith_render-node (ast-child 'val n))
                ($xsmith_render-node (ast-child 'cond n))
Guy Watson's avatar
Guy Watson committed
552
                `(br_if ,(ast-child 'targetindex n))))]
553
554
 [MemStore (λ (n)
              (append
555
556
                ($xsmith_render-node (ast-child 'address n))
                ($xsmith_render-node (ast-child 'value n))
557
                `(,(prefix-type n '.store)
558
559
                   ,(string->symbol (format "offset=~a" (ast-child 'offset n))) 
                   ,(string->symbol (format "align=~a" (expt 2 (ast-child 'alignment n)))))
560
                ($xsmith_render-node (ast-child 'expr n))))]
561
562
 [MemLoad (λ (n)
             (append
563
               ($xsmith_render-node (ast-child 'address n))
564
               `(,(prefix-type n '.load)
565
566
                  ,(string->symbol (format "offset=~a" (ast-child 'offset n))) 
                  ,(string->symbol (format "align=~a" (expt 2 (ast-child 'alignment n)))))))]
567
568
569
570
571
 [LocalGet (λ (n)
              (append
                `(local.get ,(ast-child 'index n))))]
 [LocalSet (λ (n)
              (append
572
                ($xsmith_render-node (ast-child 'val n))
573
                `(local.set ,(ast-child 'index n))
574
                ($xsmith_render-node (ast-child 'expr n))))]
Guy Watson's avatar
Guy Watson committed
575
576
 [LocalTee (λ (n)
              (append
577
                ($xsmith_render-node (ast-child 'val n))
Guy Watson's avatar
Guy Watson committed
578
                `(local.tee ,(ast-child 'index n))))]
579
580
 [GlobalGet (λ (n)
               (append
581
                 `(global.get ,(string->symbol (format "$~a" (ast-child 'name n))))))]
582
583
 [GlobalSet (λ (n)
               (append
584
                 ($xsmith_render-node (ast-child 'val n))
585
                 `(global.set ,(string->symbol (format "$~a" (ast-child 'name n))))
586
                 `(global.get ,(string->symbol (format "$~a" (ast-child 'name n))))))]
587
 [TruncateFloat (λ (n)
588
589
590
591
592
593
594
595
                   (append
                     ($xsmith_render-node (ast-child 'expr n))
                     `(,(let* ([prefix-type (get-base-type-name n)]
                               [suffix-type (get-base-type-name (ast-child 'expr n))]
                               [instruction (format "~a.~a_~a" prefix-type 'trunc suffix-type)])
                          (if (ast-child 'sign n)
                            (string->symbol (format "~a~a" instruction '_s))
                            (string->symbol (format "~a~a" instruction '_u)))))))]
596
 [ConvertInt (λ (n)
597
598
599
600
601
602
603
604
                (append
                  ($xsmith_render-node (ast-child 'expr n))
                  `(,(let* ([prefix-type (get-base-type-name n)]
                            [suffix-type (get-base-type-name (ast-child 'expr n))]
                            [instruction (format "~a.~a_~a" prefix-type 'convert suffix-type)])
                       (if (ast-child 'sign n)
                         (string->symbol (format "~a~a" instruction '_s))
                         (string->symbol (format "~a~a" instruction '_u)))))))]
605
 [Wrap (λ (n)
606
          (append
607
608
609
            ($xsmith_render-node (ast-child 'expr n))
            '(i32.wrap_i64)))]
 [Extend (λ (n) ;;todo: add support for different extension widths: Section 5.4.5, v1.1
610
            (append
611
612
613
614
              ($xsmith_render-node (ast-child 'expr n))
              `(,(if (ast-child 'sign n)
                   'i64.extend_i32_s
                   'i64.extend_i32_u))))]
615
 [Demote (λ (n)
616
            (append
617
618
              ($xsmith_render-node (ast-child 'expr n))
              '(f32.demote_f64)))]
619
 [Promote (λ (n)
620
             (append
621
622
               ($xsmith_render-node (ast-child 'expr n))
               '(f64.promote_f32)))]
623
624
 [ReinterpretIntThirtyTwo (λ (n)
                             (append
625
626
                               ($xsmith_render-node (ast-child 'expr n))
                               '(f32.reinterpret_i32)))]
627
628
 [ReinterpretIntSixtyFour (λ (n)
                             (append
629
630
                               ($xsmith_render-node (ast-child 'expr n))
                               '(f64.reinterpret_i32)))]
631
632
 [ReinterpretFloatThirtyTwo (λ (n)
                               (append
633
634
                                 ($xsmith_render-node (ast-child 'expr n))
                                 '(i32.reinterpret_f32)))]
Guy Watson's avatar
Guy Watson committed
635
636
 [ReinterpretFloatSixtyFour (λ (n)
                               (append
637
638
                                 ($xsmith_render-node (ast-child 'expr n))
                                 '(i64.reinterpret_i64)))]
639
)
Guy Watson's avatar
Guy Watson committed
640

641
642
643
;; Convenience function to get the type of the node
;; Checks that the type is a valid leaf node type, and converts
;; the result into a symbol for ease of use in the renderer
Guy Watson's avatar
Guy Watson committed
644

Guy Watson's avatar
Guy Watson committed
645
646
647
(add-prop
 wasm-like
 render-hole-info
648
649
 [#f (λ (n)
        (append 
650
          `(,(string->symbol "<HOLE>"))))])
Guy Watson's avatar
Guy Watson committed
651

Guy Watson's avatar
Guy Watson committed
652
(add-att-rule
653
  wasm-like math-op
654
655
656
  [Addition (λ (n) (prefix-type n '.add))]
  [Subtraction (λ (n) (prefix-type n '.sub))]
  [Multiplication (λ (n) (prefix-type n '.mul))]
657
658
  [Division (λ (n) (prefix-type n (add-signed-suffix n '.div)))]
  [Remainder (λ (n) (prefix-type n (add-signed-suffix n '.rem)))]
659
660
661
662
  [And (λ (n) (prefix-type n '.and))]
  [Or (λ (n) (prefix-type n '.or))]
  [Xor (λ (n) (prefix-type n '.xor))]
  [ShiftLeft (λ (n) (prefix-type n '.shl))]
663
  [ShiftRight (λ (n) (prefix-type n (add-signed-suffix n '.shr)))]
664
665
  [RotateLeft (λ (n) (prefix-type n '.rotl))]
  [RotateRight (λ (n) (prefix-type n '.rotr))]
666
667
668
  [Min (λ (n) (prefix-type n '.min))]
  [Max (λ (n) (prefix-type n '.max))]
  [CopySign (λ (n) (prefix-type n '.copysign))]
669

670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
  [Equal (λ (n) (prefix-type n '.eq))]
  [NotEqual (λ (n) (prefix-type n '.ne))]
  [LessThan (λ (n) (prefix-type n (add-signed-suffix n '.lt)))]
  [GreaterThan (λ (n) (prefix-type n (add-signed-suffix n '.gt)))]
  [LessThanOrEqual (λ (n) (prefix-type n (add-signed-suffix n '.le)))]
  [GreaterThanOrEqual (λ (n) (prefix-type n (add-signed-suffix n '.ge)))]

  [CountLeadingZero (λ (n) (prefix-type n '.clz))]
  [CountTrailingZero (λ (n) (prefix-type n '.ctz))]
  [NonZeroBits (λ (n) (prefix-type n '.popcnt))]
  [AbsoluteValue (λ (n) (prefix-type n '.abs))]
  [Negate (λ (n) (prefix-type n '.neg))]
  [SquareRoot (λ (n) (prefix-type n '.sqrt))]
  [Ceiling (λ (n) (prefix-type n '.ceil))]
  [Floor (λ (n) (prefix-type n '.floor))]
  [Truncate (λ (n) (prefix-type n '.trunc))]
  [Nearest (λ (n) (prefix-type n '.nearest))]
 
  [EqualZero (λ (n) (prefix-type n '.eqz))]
Guy Watson's avatar
Guy Watson committed
689
)
690
691
692
693

;; Adds a sign suffix if needed. It can differentiate between float and int for 
;; nodes like division, which only need a sign suffix on the int base-type
(define (add-signed-suffix node instruction)
Guy Watson's avatar
Guy Watson committed
694
  (let ([node-type (get-base-type-name node)])
695
696
    (cond [(or (eq? node-type 'i32) (eq? node-type 'i64))
           (if (ast-child 'sign node)
697
698
             (string->symbol (format "~a~a" instruction '_s))
             (string->symbol (format "~a~a" instruction '_u)))]
699
700
701
702
          [(or (eq? node-type 'f32) (eq? node-type 'f64))
           instruction] ;; floats don't need any suffixes
          [else
            (begin
Guy Watson's avatar
Guy Watson committed
703
              (eprintf "Node type not a base type when adding a signed suffix\n")
704
              '<ERROR>)])))
705

706
 
707
;; This line defines `webassembly-generate-ast`.
Guy Watson's avatar
Guy Watson committed
708
(assemble-spec-components webassembly wasm-like)
709
 
710
(xsmith-command-line (λ () (parameterize ([current-xsmith-type-constructor-thunks
711
                                           (list (λ () i32))])
712
                             (webassembly-generate-ast 'Program)))
713
714
715
                     #:comment-wrap (λ (lines)
                                      (string-join
                                       (map (λ (x) (format ";; ~a" x)) lines)
Guy Watson's avatar
Guy Watson committed
716
717
                                       "\n"))
                     #:format-render (λ (s-exp)
Guy Watson's avatar
Guy Watson committed
718
719
720
                                      (substring
                                        (pretty-format s-exp)
                                        1)))
721
722


Guy Watson's avatar
Guy Watson committed
723
724
725
726
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; End of file.