worst-scheme-compiler-ever.rkt

#lang racket

(define (macro-expand s)
  (match s
    [(list 'let vs b)
     (define xs (map car vs))
     (define es (map cadr vs))
     (macro-expand `((lambda ,xs ,b) ,@es))]
    [(list 'let* vs b)
     (define xs (map car vs))
     (define es (map cadr vs))
     (macro-expand (foldr (λ (x e r) `(let ([,x ,e]) ,r)) b xs es))]
    [(list 'lambda xs b) `(lambda ,xs ,(macro-expand b))]
    [(list 'quote _) s]
    [(? pair?) `(#%app ,@(map macro-expand s))]
    [(? symbol?) s]
    [_ `',s]))

(define (+b . args) (for-each write-byte args))
(define (++ . args) (for-each write-bytes args))

(define (+u n)
  (if (< n #x80)
      (+b n)
      (let ([m (bitwise-ior (bitwise-and n #x7f) #x80)]
            [n (arithmetic-shift n -7)])
        (+b m)
        (+u n))))

(define (+s n)
  (if (< #x-40 n #x40)
      (write-byte (bitwise-and n #x7f))
      (let ([m (bitwise-ior (bitwise-and n #x7f) #x80)]
            [n (arithmetic-shift n -7)])
        (+b m)
        (+s n))))

(define (+list f xs)
  (+u (length xs))
  (for-each f xs))

(define (+str s)
  (define bs (string->bytes/utf-8 s))
  (+u (bytes-length bs))
  (++ bs))

(define (+section f)
  (define bs (with-output-to-bytes f))
  (+u (bytes-length bs))
  (++ bs))

(struct func [type locals expr])

(define lambdas (make-hasheqv))
(define lambda-count 0)

(define (compile-lambda e env args)
  (define fp lambda-count)
  (set! lambda-count (add1 fp))
  (hash-set! lambdas fp
             (with-output-to-bytes
               (λ ()
                 (for ([arg (in-list args)])
                   (+args) (+car) (+env) (+cons) (+set-env!)
                   (+args) (+cdr) (+set-args!))
                 (define env* (append (reverse args) env))
                 (parameterize ([current-env env*])
                   (+expr e)
                   (++ #"\x0b")))))
  fp)

(define current-env
  (make-parameter '()))

(define (+expr e)
  (match e
    [(? symbol? x)
     (define n (or (index-of (current-env) x)
                   (error "unbound:" x)))
     (+env)
     (for ([i (in-range n)]) (+cdr))
     (+car)]

    [(list 'quote (? exact-integer? n))
     ; (i32.const n)
     (++ #"\x41") (+s n)
     ; (i31.ref)
     (++ #"\xfb\x1c")]

    [(list '#%app (app int-opcode (? bytes? opc)) e1 e2)
     (for ([e (in-list (list e1 e2))])
       (+expr e)
       ; (ref.cast) (i31.get_s)
       (++ #"\xfb\x16\x6c\xfb\x1d"))
     ; (i32.ref)
     (++ opc #"\xfb\x1c")]

    [(list 'lambda xs e)
     (define fp (compile-lambda e (current-env) xs))
     (+env)
     ; (i32.const fp)
     (++ #"\x41") (+s fp)
     ; (struct.new 3)
     (++ #"\xfb\x00\x03")]

    [(cons '#%app (cons f es))
     (for ([e (in-list es)]) (+expr e))
     (+null)
     (for ([e (in-list es)]) (+cons))
     (+expr f)
     ; (ref.cast 3)
     ; (local.tee 2)
     ; (struct.get 0)
     ; (local.get 2)
     ; (struct.get 1)
     ; (call_indirect)
     (++ #"\xfb\x16\x03"
         #"\x22\x02"
         #"\xfb\x02\x03\x00"
         #"\x20\x02"
         #"\xfb\x02\x03\x01"
         #"\x11\x01\x00")]))

(define (int-opcode sym)
  (match sym
    ['+ #"\x6a"]
    ['- #"\x6b"]
    ['* #"\x6c"]
    [_ #f]))

(define (+null) (++ #"\xd0\x6e"))
(define (+cons) (++ #"\xfb\x00\x02"))
(define (+car) (++ #"\xfb\x16\x02\xfb\x02\x02\x00"))
(define (+cdr) (++ #"\xfb\x16\x02\xfb\x02\x02\x01"))

(define (+args) (++ #"\x20\x00"))
(define (+set-args!) (++ #"\x21\x00"))
(define (+env) (++ #"\x20\x01"))
(define (+set-env!) (++ #"\x21\x01"))

(module+ main
  (define types
    '(; (type 0 (func (result i32)))
      #"\x60\x00\x01\x7f"
      ; (type 1 (func (param anyref) (param anyref) (result anyref)))
      #"\x60\x02\x6e\x6e\x01\x6e"
      ; (type 2 (struct (field mut anyref) (field anyref)))
      #"\x5f\x02\x6e\x01\x6e\x00"
      ; (type 3 (struct (field anyref) (field i32)))
      #"\x5f\x02\x6e\x00\x7f\x00"))

  (define main
    (read))

  (define main*
    (macro-expand main))

  (define main-fp
    (compile-lambda main* '() '()))

  (define start-expr
    (with-output-to-bytes
      (λ ()
        (+null)
        (+null)
        ; (call main)
        (++ #"\x10") (+u main-fp)
        ; (ref.cast) (i31.get_s) (end)
        (++ #"\xfb\x16\x6c\xfb\x1d\x0b"))))

  (define start-fp
    lambda-count)

  (define funcs
    (append (map (λ (fp) (func 1 '(#"\x01\x03") (hash-ref lambdas fp)))
                 (range lambda-count))
            (list (func 0 '() start-expr))))

  (++ #"\0asm\x01\0\0\0")
  ; types section
  (+b 1)
  (+section (λ () (+list ++ types)))
  ; function section
  (+b 3)
  (+section (λ () (+list +u (map func-type funcs))))
  ; table section
  (+b 4)
  (+section (λ ()
              (+u 1)
              (++ #"\x70\x00")
              (+u lambda-count)))
  ; export section
  (+b 7)
  (+section (λ ()
              (+u 1)
              ; (export "main" (func 0))
              (+str "main") (++ #"\x00") (+u start-fp)))
  ; element section
  (+b 9)
  (+section (λ ()
              (+u 1)
              (++ #"\x00\x41\x00\x0b")
              (+list +u (range lambda-count))))
  ; code section
  (+b 10)
  (+section (λ ()
              (+list (λ (f)
                       (+section (λ ()
                                   (+list ++ (func-locals f))
                                   (++ (func-expr f)))))
                     funcs))))