wasmlike.rkt

#lang xsmith/private/base 
;; -*- 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.

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

(require
  xsmith
  xsmith/racr-convenience
  xsmith/app
  racr
  racket/class
  racket/pretty
  racket/string
  racket/match
  (except-in racket/list empty))
 
(define-spec-component wasm-like)

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

;; This defines the layout of the grammar.
(add-to-grammar
 wasm-like
 [Program #f (Func
               ;;[main : Func]
              [globals : GlobalDeclaration *])]
 [Func #f ([root : Expr]
           [localcount = (random 1 10)])]
 [Expr #f ()
       #:prop may-be-generated #f]
 [Literal Expr ()
          #:prop choice-weight 3 ;; default is 10
          #:prop may-be-generated #f]
 [LiteralIntThirtyTwo Literal ([v = (random -1000 1000)]) ;;todo add command line feature for the whole range
                      #:prop choice-weight 3]
 [LiteralIntSixtyFour Literal ([v = (random -1000 1000)])
                      #:prop choice-weight 3]
 [LiteralFloatThirtyTwo Literal ([v = (+ (random -1000 1000) (random))])
                        #:prop choice-weight 3]
 [LiteralFloatSixtyFour Literal ([v = (+ (random -1000 1000) (random))])
                        #:prop choice-weight 3]

 [Noop Expr ([expr : Expr])]
 [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]

 [Addition Binop ()]
 [Subtraction Binop ()]
 [Multiplication Binop ()]
 [Division Binop ([sign = (choose-random-sign)])] ;;These signs only matter for ints, not floats
 [Remainder Binop ([sign = (choose-random-sign)])]
 [And Binop ()]
 [Or Binop ()]
 [Xor Binop ()]
 [ShiftLeft Binop ()]
 [ShiftRight Binop ([sign = (choose-random-sign)])]
 [RotateLeft Binop ()]
 [RotateRight Binop ()]
 [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)])]

 [CountLeadingZero Unop ()]  ;; According to the spec, these are unops, not testops
 [CountTrailingZero Unop ()]
 [NonZeroBits Unop ()]
 [AbsoluteValue Unop ()]
 [Negate Unop ()]
 [SquareRoot Unop ()]
 [Ceiling Unop ()]
 [Floor Unop ()]
 [Truncate Unop ()]
 [Nearest Unop ()]

 [EqualZero Testop ()]
 
 [IfElse Expr ([cond : Expr]
               [then : Expr]
               [else : Expr])
         #:prop choice-weight 10]
 [If Expr ([cond : Expr]
           [then : Expr])]
 [Block Expr ([expr : Expr])]
 [Loop Expr ([expr : Expr])]
 [Branch Expr ([val : Expr]
               [targetnode]
               [targetindex]) ;; a number depth
         ;; todo: the type of val should be unified with the target node
         #:prop choice-weight 10]
 [BranchIf Expr ([cond : Expr]
                 [val : Expr]
                 [targetnode]
                 [targetindex])
           #:prop choice-weight 10]
 [MemStore Expr ([address : LiteralIntThirtyTwo]
                 [value : Expr]
                 [offset = (abs (- (random 20000) 10000))] ;; This probably has some bias towards 0
                 [alignment = (random 4)]
                 [expr : Expr])
           #:prop choice-weight 3]
 [MemLoad Expr ([address : LiteralIntThirtyTwo]
                [offset = (abs (- (random 20000) 10000))]
                [alignment = (random 4)])
           #:prop choice-weight 3]
 [LocalGet Expr ([index])
           #:prop choice-weight 5] ;;todo Change these over to the xsmith reference system once random reference increases are implemented by William
 [LocalSet Expr ([val : Expr]
                 [index]
                 [expr : Expr])
           #:prop choice-weight 5]
 [LocalTee Expr ([val : Expr]
                 [index])
           #:prop choice-weight 5]
 [GlobalDeclaration #f ([name]
                        [type]
                        [initialvalue : Literal])
                    #:prop binder-info (name type definition)]
 [GlobalGet Expr ([name])
            #:prop reference-info (read name)
            #:prop choice-weight 4] 
 [GlobalSet Expr ([val : Expr]
                  [name])
            #:prop reference-info (write name)
            #:prop choice-weight 4]

 ;; Type conversions
 [TypeConversion Expr ([expr : Expr])
                 #:prop choice-weight 20
                 #:prop may-be-generated #f]
 [TruncateFloat TypeConversion ([sign = (choose-random-sign)])]  ;; float -> int
 [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
 [ReinterpretIntThirtyTwo TypeConversion ()]
 [ReinterpretIntSixtyFour TypeConversion ()]
 [ReinterpretFloatThirtyTwo TypeConversion ()]
 [ReinterpretFloatSixtyFour TypeConversion ()]


 ;; Idiomatic Generation
 [ForLoop Expr ([initial : Literal]
                [loopvar : GlobalSet]
                [loopbody : Expr])
          #:prop choice-weight 10]
 
 )

(add-prop
  wasm-like
  fresh
  [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))]
  [LocalGet (hash 'index (choose-local-target (current-hole)))]
  [LocalSet (hash 'index (choose-local-target (current-hole)))]
  [LocalTee (hash 'index (choose-local-target (current-hole)))]

  #;[GlobalGet (hash 'name (fresh-var-name "$global_"))]
  #;[GlobalSet (hash 'name (fresh-var-name "$global_"))]
  ;;todo Implement these with the upcoming custom name changes  
 
  ;; Let the initial value and loop body be handled by the default
  [ForLoop (hash 'loopvar (make-fresh-node 
                            'GlobalSet
                            (hash 'val (make-fresh-node 'LiteralIntThirtyTwo) ;;dummy
                                  'name (binding-name (send this xsmith_get-reference-for-child! i32 #t)))))]
)

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

;; All the base types of WebAssembly
(define i32 (base-type 'i32))
(define i64 (base-type 'i64))
(define f32 (base-type 'f32))
(define f64 (base-type 'f64))
;; Larger groups - use when ALL the contained types are valid
(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))

(define (no-child-types)
  (λ (n t)
     (hash)))

(define (binop-rhs) (λ (n t)
                       (hash 'l t
                             'r t)))
(define (unop-rhs) (λ (n t)
                      (hash 'expr t)))

(add-prop
 wasm-like type-info
          [Program [i32
                    (λ (n t) 
                       (hash 'Func i32
                             'globals (λ (child-node) (fresh-number))))]]
          [GlobalDeclaration [(fresh-number)
                               (λ (n t) (hash 'initialvalue t))]]
          [Func [(fresh-number) 
                 (λ (n t)
                    (hash 'root t))]]
          [LiteralIntThirtyTwo [i32
                                 (no-child-types)]]
          [LiteralIntSixtyFour [i64
                                 (no-child-types)]]
          [LiteralFloatThirtyTwo [f32
                                   (no-child-types)]]
          [LiteralFloatSixtyFour [f64
                                   (no-child-types)]]
          [Noop [(fresh-number) (λ (n t) (hash 'expr t))]] ;;todo This is wierd....
          
          [Binop [(fresh-number) (binop-rhs)]]
          ;; Restricted binops:
          [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)]]

          [Unop [(fresh-number) (unop-rhs)]]
          ;; Restricted Unops
          [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)]]
          
          [Comparison [i32
                        (λ (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))]]
          [Testop [i32
                    (λ (n t) ;; The only testop in wasm 1.1 is integer only
                       (hash 'expr (fresh-int)))]]
          [IfElse [(fresh-number)
                    (λ (n t)
                     (hash 'cond i32
                           'then t
                           'else t))]]
          [If [(fresh-number)
                (λ (n t)
                   (hash 'cond i32
                         'then t))]]


          [Block [(fresh-number) (λ (n t) (hash 'expr t))]]
          [Loop [(fresh-number) (λ (n t) (hash 'expr t))]]
          [ForLoop [(fresh-number) (λ (n t) (hash 'initial i32
                                            'loopvar i32
                                            'loopbody t))]]
          [Branch [(fresh-number) (λ (n t) (hash 'val t))]] ;;todo triple check branch interactions here
          [BranchIf [(fresh-number) 
                     (λ (n t) (hash 'cond i32
                                    'val t))]]
          [MemStore [(fresh-number)
                     (λ (n t) (hash 'address i32 
                                    'value t
                                    'expr t))]]
          [MemLoad [(fresh-number) (λ (n t) (hash 'address i32))]]
          [LocalGet [i32 (no-child-types)]] ;;todo change to the new reference binding system
          [LocalSet [i32 (λ (n t) (hash 'val i32
                                        'expr i32))]]
          [LocalTee [i32 (λ (n t) (hash 'val i32))]]
          [GlobalGet [(fresh-number) (no-child-types)]]
          [GlobalSet [(fresh-number) (λ (n t) (hash 'val t))]]
          ;;Type conversions
          [TruncateFloat [(fresh-int) 
                     (λ (n t) 
                        (hash 'expr (fresh-float)))]]
          [ConvertInt [(fresh-float) 
                    (λ (n t) 
                       (hash 'expr (fresh-int)))]]
          [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))]]
          [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))]]
)

;; Define structured control instruction property
(define-non-inheriting-rule-property
  structured-control-instruction
  att-rule
  #:default (λ (n) #f)
  )

(add-prop
 wasm-like
 structured-control-instruction
 [Func (λ (n) #t)]
 [IfElse (λ (n) #t)]
 [If (λ (n) #t)]
 [Block (λ (n) #t)]
 [Loop (λ (n) #t)])

(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))

(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)))]
  [If (λ (n c)
         (not (eq? (ast-child 'cond n) c)))]
  [ForLoop (λ (n c)
              (not (eq? (ast-child 'loopvar n) c)))]
  )


(define (choose-br-target n)
  (let* ([parents (get-parents n)]
         [targets (valid-br-targets parents)]
         [index (random (length targets))])
    (cons index (list-ref targets index))))

(define (get-func-node n)
  (if (eq? (node-type n) 'Func)
    n
    (get-func-node (parent-node n))))

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

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

;; 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))))
         

(add-prop
 wasm-like
 render-node-info
 [Program (λ (n) `(module
                    (import "env" "memory" (memory $mem 1))
                    (import "env" "addToCrc" (func $addToCrc (param i32)))
                    (import "env" "__memory_base" (global $mem_base i32))
                    ,@(map (λ (global)
                             `(global ,(string->symbol (format "$~a" (ast-child 'name global))) 
                                      (mut ,(get-base-type-name global))
                                      ,($xsmith_render-node (ast-child 'initialvalue global))))
                        (reverse (ast-children (ast-child 'globals n))))
                    ,($xsmith_render-node (ast-child 'Func n))
                    (global $mem_base_internal (mut i32) (i32.const 0))
                    (global $mem_max_internal (mut i32) (i32.const 0))
                    (func (export "__post_instantiate")
                          global.get $mem_base
                          global.set $mem_base_internal
                          global.get $mem_base_internal
                          i32.const 5242880
                          i32.add
                          global.set $mem_max_internal)
                    (func (export "_crc_globals")
                       ,@(flatten (map (λ (global) (append
                                                    '(global.get)
                                                    (list (string->symbol (format "$~a" (ast-child 'name global))))
                                                    '(call $addToCrc)))
                              (reverse (ast-children (ast-child 'globals n))))))))]
 [Func (λ (n) `(func (export "_func") (result i32)
                      (local ,@(make-list (ast-child 'localcount n) 'i32)) ;;todo convert to new method
                     ,@($xsmith_render-node (ast-child 'root n))))]
 [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)))]
 [Noop (λ (n) (append
                 '(nop)
                 ($xsmith_render-node (ast-child 'expr n))))]
 [Binop (λ (n) (append 
                  ($xsmith_render-node (ast-child 'l n))
                  ($xsmith_render-node (ast-child 'r n))
                  (list (att-value 'math-op n))))]
 [Unop (λ (n) (append
                 ($xsmith_render-node (ast-child 'expr n))
                 (list (att-value 'math-op n))))]
 [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))))]
 [IfElse (λ (n)           
           (append
                ($xsmith_render-node (ast-child 'cond n))
                `(if (result ,(get-base-type-name n)))
                ($xsmith_render-node (ast-child 'then n))
                '(else)
                ($xsmith_render-node (ast-child 'else n))
                '(end)))]
 [If (λ (n)
        (append
          ($xsmith_render-node (ast-child 'cond n))
          `(if (result ,(get-base-type-name n)))
          ($xsmith_render-node (ast-child 'then n))
          '(end)))]
 [Block (λ (n)
           (append
             `(block (result ,(get-base-type-name n)))
             ($xsmith_render-node (ast-child 'expr n))
             '(end)))]
 [Loop (λ (n)
          (append
            `(loop (result ,(get-base-type-name n)))
            ($xsmith_render-node (ast-child 'expr n))
            '(end)))]

 [ForLoop (λ (n)
             (append
                 ($xsmith_render-node (ast-child 'initial n))
                 `(global.set ,(string->symbol (format "$~a" (ast-child 'name (ast-child 'loopvar n)))))
                 `(loop (result ,(get-base-type-name n)))
                 `(global.get ,(string->symbol (format "$~a" (ast-child 'name (ast-child 'loopvar n)))))
                 '(i32.const 1)
                 '(i32.sub)
                 `(global.set ,(string->symbol (format "$~a" (ast-child 'name (ast-child 'loopvar n)))))
                 ;; 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)))]
 [Branch (λ (n)
            (append
              ($xsmith_render-node (ast-child 'val n))
              `(br ,(ast-child 'targetindex n))))]
 [BranchIf (λ (n)
              (append
                ($xsmith_render-node (ast-child 'val n))
                ($xsmith_render-node (ast-child 'cond n))
                `(br_if ,(ast-child 'targetindex n))))]
 [MemStore (λ (n)
              (append
                ($xsmith_render-node (ast-child 'address n))
                ($xsmith_render-node (ast-child 'value n))
                `(,(prefix-type n '.store)
                   ,(string->symbol (format "offset=~a" (ast-child 'offset n))) 
                   ,(string->symbol (format "align=~a" (expt 2 (ast-child 'alignment n)))))
                ($xsmith_render-node (ast-child 'expr n))))]
 [MemLoad (λ (n)
             (append
               ($xsmith_render-node (ast-child 'address n))
               `(,(prefix-type n '.load)
                  ,(string->symbol (format "offset=~a" (ast-child 'offset n))) 
                  ,(string->symbol (format "align=~a" (expt 2 (ast-child 'alignment n)))))))]
 [LocalGet (λ (n)
              (append
                `(local.get ,(ast-child 'index n))))]
 [LocalSet (λ (n)
              (append
                ($xsmith_render-node (ast-child 'val n))
                `(local.set ,(ast-child 'index n))
                ($xsmith_render-node (ast-child 'expr n))))]
 [LocalTee (λ (n)
              (append
                ($xsmith_render-node (ast-child 'val n))
                `(local.tee ,(ast-child 'index n))))]
 [GlobalGet (λ (n)
               (append
                 `(global.get ,(string->symbol (format "$~a" (ast-child 'name n))))))]
 [GlobalSet (λ (n)
               (append
                 ($xsmith_render-node (ast-child 'val n))
                 `(global.set ,(string->symbol (format "$~a" (ast-child 'name n))))
                 `(global.get ,(string->symbol (format "$~a" (ast-child 'name n))))))]
 [TruncateFloat (λ (n)
                   (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)))))))]
 [ConvertInt (λ (n)
                (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)))))))]
 [Wrap (λ (n)
          (append
            ($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
            (append
              ($xsmith_render-node (ast-child 'expr n))
              `(,(if (ast-child 'sign n)
                   'i64.extend_i32_s
                   'i64.extend_i32_u))))]
 [Demote (λ (n)
            (append
              ($xsmith_render-node (ast-child 'expr n))
              '(f32.demote_f64)))]
 [Promote (λ (n)
             (append
               ($xsmith_render-node (ast-child 'expr n))
               '(f64.promote_f32)))]
 [ReinterpretIntThirtyTwo (λ (n)
                             (append
                               ($xsmith_render-node (ast-child 'expr n))
                               '(f32.reinterpret_i32)))]
 [ReinterpretIntSixtyFour (λ (n)
                             (append
                               ($xsmith_render-node (ast-child 'expr n))
                               '(f64.reinterpret_i32)))]
 [ReinterpretFloatThirtyTwo (λ (n)
                               (append
                                 ($xsmith_render-node (ast-child 'expr n))
                                 '(i32.reinterpret_f32)))]
 [ReinterpretFloatSixtyFour (λ (n)
                               (append
                                 ($xsmith_render-node (ast-child 'expr n))
                                 '(i64.reinterpret_i64)))]
)

;; 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

(add-prop
 wasm-like
 render-hole-info
 [#f (λ (n)
        (append 
          `(,(string->symbol "<HOLE>"))))])

(add-att-rule
  wasm-like math-op
  [Addition (λ (n) (prefix-type n '.add))]
  [Subtraction (λ (n) (prefix-type n '.sub))]
  [Multiplication (λ (n) (prefix-type n '.mul))]
  [Division (λ (n) (prefix-type n (add-signed-suffix n '.div)))]
  [Remainder (λ (n) (prefix-type n (add-signed-suffix n '.rem)))]
  [And (λ (n) (prefix-type n '.and))]
  [Or (λ (n) (prefix-type n '.or))]
  [Xor (λ (n) (prefix-type n '.xor))]
  [ShiftLeft (λ (n) (prefix-type n '.shl))]
  [ShiftRight (λ (n) (prefix-type n (add-signed-suffix n '.shr)))]
  [RotateLeft (λ (n) (prefix-type n '.rotl))]
  [RotateRight (λ (n) (prefix-type n '.rotr))]
  [Min (λ (n) (prefix-type n '.min))]
  [Max (λ (n) (prefix-type n '.max))]
  [CopySign (λ (n) (prefix-type n '.copysign))]

  [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))]
)

;; 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)
  (let ([node-type (get-base-type-name node)])
    (cond [(or (eq? node-type 'i32) (eq? node-type 'i64))
           (if (ast-child 'sign node)
             (string->symbol (format "~a~a" instruction '_s))
             (string->symbol (format "~a~a" instruction '_u)))]
          [(or (eq? node-type 'f32) (eq? node-type 'f64))
           instruction] ;; floats don't need any suffixes
          [else
            (begin
              (eprintf "Node type not a base type when adding a signed suffix\n")
              '<ERROR>)])))

 
;; This line defines `webassembly-generate-ast`.
(assemble-spec-components webassembly wasm-like)
 
(xsmith-command-line (λ () (parameterize ([current-xsmith-type-constructor-thunks
                                           (list (λ () i32))])
                             (webassembly-generate-ast 'Program)))
                     #:comment-wrap (λ (lines)
                                      (string-join
                                       (map (λ (x) (format ";; ~a" x)) lines)
                                       "\n"))
                     #:format-render (λ (s-exp)
                                      (substring
                                        (pretty-format s-exp)
                                        1)))


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

;; End of file.