wasmlike.rkt 29.3 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
80
 [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)
         #:prop may-be-generated #f]
81

82
 [Addition Binop ()]
Guy Watson's avatar
Guy Watson committed
83
84
 [Subtraction Binop ()]
 [Multiplication Binop ()]
85
86
 [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
87
88
89
 [And Binop ()]
 [Or Binop ()]
 [Xor Binop ()]
90
 [ShiftLeft Binop ()]
91
 [ShiftRight Binop ([sign = (choose-random-sign)])]
92
93
 [RotateLeft Binop ()]
 [RotateRight Binop ()]
94
95
96
97
98
99
100
101
102
103
104
105
 [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)])]

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

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

168
169
170
171
 ;; Type conversions
 [TypeConversion Expr ([expr : Expr])
                 #:prop choice-weight 20
                 #:prop may-be-generated #f]
172
 [TruncateFloat TypeConversion ([sign = (choose-random-sign)])]  ;; float -> int
173
174
175
176
177
 [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
178
179
180
181
 [ReinterpretIntThirtyTwo TypeConversion ()]
 [ReinterpretIntSixtyFour TypeConversion ()]
 [ReinterpretFloatThirtyTwo TypeConversion ()]
 [ReinterpretFloatSixtyFour TypeConversion ()]
182
183


184
 ;; Idiomatic Generation
185
186
187
 [ForLoop Expr ([initial : Literal]
                [loopvar : GlobalSet]
                [loopbody : Expr])
188
          #:prop choice-weight 10]
189
 
190
191
192
193
194
 )

(add-prop
  wasm-like
  fresh
Guy Watson's avatar
Guy Watson committed
195
196
197
198
199
200
201
202
203
204
205
  [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))]
206
207
  [LocalGet (hash 'index (choose-local-target (current-hole)))]
  [LocalSet (hash 'index (choose-local-target (current-hole)))]
Guy Watson's avatar
Guy Watson committed
208
  [LocalTee (hash 'index (choose-local-target (current-hole)))]
209
210
211

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

(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))))]
230
  [Func (λ (n c) (+ 1 (att-value 'nesting-level (ast-parent n))))])
231

232
;; All the base types of WebAssembly
233
234
235
236
(define i32 (base-type 'i32))
(define i64 (base-type 'i64))
(define f32 (base-type 'f32))
(define f64 (base-type 'f64))
237
;; Larger groups - use when ALL the contained types are valid
238
239
240
(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))
241

242
(define (no-child-types)
243
244
  (λ (n t)
     (hash)))
245

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

252
253
(add-prop
 wasm-like type-info
254
          [Program [i32
255
                    (λ (n t) 
256
                       (hash 'Func i32
257
258
                             'globals (λ (child-node) (fresh-number))))]]
          [GlobalDeclaration [(fresh-number)
259
                               (λ (n t) (hash 'initialvalue t))]]
260
          [Func [(fresh-number) 
261
262
                 (λ (n t)
                    (hash 'root t))]]
263
          [LiteralIntThirtyTwo [i32
264
                                 (no-child-types)]]
265
          [LiteralIntSixtyFour [i64
266
                                 (no-child-types)]]
267
          [LiteralFloatThirtyTwo [f32
268
                                   (no-child-types)]]
269
          [LiteralFloatSixtyFour [f64
270
                                   (no-child-types)]]
271
          [Noop [(fresh-number) (λ (n t) (hash 'expr t))]] ;;todo This is wierd....
272
          
273
          [Binop [(fresh-number) (binop-rhs)]]
274
          ;; Restricted binops:
275
276
277
278
279
280
281
282
283
284
285
          [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)]]
286

287
          [Unop [(fresh-number) (unop-rhs)]]
288
          ;; Restricted Unops
289
290
291
292
293
294
295
296
297
298
          [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)]]
299
          
300
          [Comparison [i32
301
302
303
304
                        (λ (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))]]
305
306
          [Testop [i32
                    (λ (n t) ;; The only testop in wasm 1.1 is integer only
307
308
                       (hash 'expr (fresh-int)))]]
          [IfElse [(fresh-number)
309
                    (λ (n t)
310
311
312
                     (hash 'cond i32
                           'then t
                           'else t))]]
313
          [If [(fresh-number)
314
                (λ (n t)
315
316
                   (hash 'cond i32
                         'then t))]]
317
318


319
320
321
          [Block [(fresh-number) (λ (n t) (hash 'expr t))]]
          [Loop [(fresh-number) (λ (n t) (hash 'expr t))]]
          [ForLoop [(fresh-number) (λ (n t) (hash 'initial i32
322
323
                                            'loopvar i32
                                            'loopbody t))]]
324
325
          [Branch [(fresh-number) (λ (n t) (hash 'val t))]] ;;todo triple check branch interactions here
          [BranchIf [(fresh-number) 
326
327
                     (λ (n t) (hash 'cond i32
                                    'val t))]]
328
          [MemStore [(fresh-number)
329
330
331
                     (λ (n t) (hash 'address i32 
                                    'value t
                                    'expr t))]]
332
          [MemLoad [(fresh-number) (λ (n t) (hash 'address i32))]]
333
          [LocalGet [i32 (no-child-types)]] ;;todo change to the new reference binding system
334
335
336
          [LocalSet [i32 (λ (n t) (hash 'val i32
                                        'expr i32))]]
          [LocalTee [i32 (λ (n t) (hash 'val i32))]]
337
338
          [GlobalGet [(fresh-number) (no-child-types)]]
          [GlobalSet [(fresh-number) (λ (n t) (hash 'val t))]]
339
          ;;Type conversions
340
          [TruncateFloat [(fresh-int) 
341
                     (λ (n t) 
342
343
                        (hash 'expr (fresh-float)))]]
          [ConvertInt [(fresh-float) 
344
                    (λ (n t) 
345
                       (hash 'expr (fresh-int)))]]
346
347
348
349
350
351
352
353
          [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))]]
354
355
356
357
358
359
360
361
          [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
362
)
363

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

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

380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
(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))

399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
(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)))]
414
415
  [If (λ (n c)
         (not (eq? (ast-child 'cond n) c)))]
416
417
  [ForLoop (λ (n c)
              (not (eq? (ast-child 'loopvar n) c)))]
418
  )
419

Guy Watson's avatar
Guy Watson committed
420
421
422
423
424

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

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

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

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

441
442
443
444
445
446
447
448
;; 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
449

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

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

639
640
641
;; 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
642

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

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

668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
  [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
687
)
688
689
690
691

;; 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
692
  (let ([node-type (get-base-type-name node)])
693
694
    (cond [(or (eq? node-type 'i32) (eq? node-type 'i64))
           (if (ast-child 'sign node)
695
696
             (string->symbol (format "~a~a" instruction '_s))
             (string->symbol (format "~a~a" instruction '_u)))]
697
698
699
700
          [(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
701
              (eprintf "Node type not a base type when adding a signed suffix\n")
702
              '<ERROR>)])))
703

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


Guy Watson's avatar
Guy Watson committed
721
722
723
724
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; End of file.