go-runtime.rkt

#lang racket/base

(require (for-syntax racket/base
                     syntax/parse/lib/function-header)
         data/gvector
         monotonic
         (prefix-in http: net/http-easy)
         racket/contract
         racket/math
         racket/random
         syntax/parse/define
         wasm/private/memory
         wasm/private/vm)

(provide
 current-vm
 *go*)

(define buf (make-bytes 65536))

(define global
  (hash
   "AbortController" (lambda ()
                       (make-hash
                        `(("signal" . `(lambda ()
                                         null)))))
   "Array" (lambda ()
             'Array)
   "Date" (lambda ()
            (hash
             "getTimezoneOffset" (lambda (_d)
                                   -120)))
   "Headers" (lambda ()
               (make-hash))
   "Object" (lambda ()
              (make-hash))
   "Uint8Array" (lambda (len)
                  (hash "buf" (make-bytes (inexact->exact len))))
   "crypto" (hash)
   "fetch" (lambda (_who uri opts)
             #;(printf "fetch uri=~s opts~s~n" uri opts)
             (define res-ch (make-channel))
             (thread
              (lambda ()
                (channel-put res-ch (http:get uri))))
             (make-hash
              `(("then" . ,(lambda (_who ok-callback err-callback)
                             (define res (channel-get res-ch))
                             (ok-callback
                              (hash
                               "ok" ((integer-in 200 299) (http:response-status-code res))
                               "status" (http:response-status-code res)
                               "headers" (hash
                                          "entries" (lambda args
                                                      (hash
                                                       "next" (lambda args
                                                                (hash "done" #t)))))
                               "body" (hash
                                       "getReader" (lambda args
                                                     (hash
                                                      "cancel" (lambda (reason)
                                                                 (hash
                                                                  "then" (lambda (_who ok-callback err-callback)
                                                                           (ok-callback reason)))))))
                               "_response" res)))))))
   "fs" (hash
         "constants" (hash
                      "O_WRONLY" -1
                      "O_RDWR"   -1
                      "O_CREAT"  -1
                      "O_TRUNC"  -1
                      "O_APPEND" -1
                      "O_EXCL"   -1)
         "write" (lambda (_fs fd buf offset len position callback)
                   (display (hash-ref buf "buf")
                            (case (inexact->exact fd)
                              [(1) (current-output-port)]
                              [(2) (current-error-port)]))
                   (callback 'null len)))
   "process" (hash)))

(define this
  (make-hash
   `(("_pendingEvent" . null)
     ("_makeFuncWrapper" . ,(lambda (this id)
                              #;(printf "making callback for id: ~s~n" id)
                              (lambda args
                                #;(printf "id: ~a args: ~a~n" id args)
                                (define event
                                  (make-hash
                                   `(("id" . ,id)
                                     ("this" . ,this)
                                     ("args" . ,args))))
                                (hash-set! this "_pendingEvent" event)
                                ((ref "resume"))
                                (hash-ref event "result")))))))

(define *values*
  (gvector +nan.0 0 'null #true #false global this))

(define *refs*
  (make-hash))

(define *go*
  (make-hash))

(define-syntax-parser define/go
  [(_ hd:function-header)
   #'(define/go hd
       (error 'hd.name "not implemented"))]
  [(_ hd:function-header body ...+)
   #:with name-str (datum->syntax #'hd.name (symbol->string (syntax->datum #'hd.name)))
   #'(begin
       (define hd body ...)
       (hash-set! *go* name-str hd.name))])

(define current-vm
  (make-parameter #f))

(define (ref id)
  (vm-ref (current-vm) id void))

(define (load-s32 ea)
  (memory-load! (ref "mem") buf ea 4)
  (integer-bytes->integer buf #t #f 0 4))

(define (load-u32 ea)
  (memory-load! (ref "mem") buf ea 4)
  (integer-bytes->integer buf #f #f 0 4))

(define (load-s64 ea)
  (memory-load! (ref "mem") buf ea 8)
  (integer-bytes->integer buf #t #f 0 8))

(define (load-u64 ea)
  (memory-load! (ref "mem") buf ea 8)
  (integer-bytes->integer buf #f #f 0 8))

(define (load-f64 ea)
  (memory-load! (ref "mem") buf ea 8)
  (floating-point-bytes->real buf #f 0 8))

(define (store-u8 ea n)
  (memory-store! (ref "mem") ea (integer->integer-bytes n 1 #f #f)))

(define (store-s32 ea n)
  (memory-store! (ref "mem") ea (integer->integer-bytes n 4 #t #f)))

(define (store-u32 ea n)
  (memory-store! (ref "mem") ea (integer->integer-bytes n 4 #f #f)))

(define (store-s64 ea n)
  (memory-store! (ref "mem") ea (integer->integer-bytes n 8 #t #f)))

(define (store-f64 ea n)
  (memory-store! (ref "mem") ea (real->floating-point-bytes n 8 #f)))

(define (load-value addr)
  (define f (load-f64 addr))
  (cond
    [(nan? f)
     (gvector-ref *values* (load-u32 addr))]
    [(zero? f)
     'undefined]
    [else f]))

(define (load-slice addr)
  (define arr (load-s64 addr))
  (define len (load-s64 (+ addr 8)))
  (define data (make-bytes len))
  (begin0 data
    (memory-load! (ref "mem") data arr len)))

(define (load-value-slice addr)
  (define arr (load-s64 addr))
  (define len (load-s64 (+ addr 8)))
  (for/list ([i (in-range len)])
    (load-value (+ arr (* i 8)))))

(define (store-value addr v)
  (define nan-head #x7FF80000)
  (cond
    [(number? v)
     (cond
       [(nan? v)
        (store-u32 (+ addr 4) nan-head)
        (store-u32 (+ addr 0) 0)]
       [(zero? v)
        (store-u32 (+ addr 4) nan-head)
        (store-u32 (+ addr 0) 1)]
       [else
        (store-f64 addr v)])]
    [(eq? v 'undefined)
     (store-f64 addr 0)]
    [(eq? v 'null)
     (store-u32 (+ addr 4) nan-head)
     (store-u32 (+ addr 0) 2)]
    [(eq? v #true)
     (store-u32 (+ addr 4) nan-head)
     (store-u32 (+ addr 0) 3)]
    [(eq? v #false)
     (store-u32 (+ addr 4) nan-head)
     (store-u32 (+ addr 0) 4)]
    [else
     (define ref
       (hash-ref *refs* v (lambda ()
                            (define ref (gvector-count *values*))
                            (gvector-add! *values* v)
                            (begin0 ref
                              (hash-set! *refs* v ref)))))
     (define flag
       (cond
         [(string? v) 1]
         [(symbol? v) 2]
         [(procedure? v) 3]
         [else 0]))
     (store-u32 (+ addr 4) (bitwise-ior nan-head flag))
     (store-u32 (+ addr 0) ref)]))

(define (load-string addr)
  (define s (load-s64 addr))
  (define len (load-s64 (+ addr 8)))
  (define data (make-bytes len))
  (memory-load! (ref "mem") data s len)
  (bytes->string/utf-8 data))

(define/go (debug . args)
  (printf "debug: ~s~n" args)
  null)

(define/go (runtime.wasmExit sp)
  (define code (load-s32 (+ sp 8)))
  (error 'runtime.wasmExit "~a" code))

(define/go (runtime.wasmWrite sp)
  (define port
    (case (load-s64 (+ 8 sp))
      [(1) (current-output-port)]
      [(2) (current-error-port)]))
  (define p (load-s64 (+ 16 sp)))
  (define n (load-s64 (+ 24 sp)))
  (define data (make-bytes n))
  (memory-load! (ref "mem") data p n)
  (begin0 null
    (display data port)))

(define origin
  (- (* (current-milliseconds) 1000000) (nanotime)))

(define/go (runtime.nanotime sp)
  (begin0 null
    (store-s64 (+ sp 8) (+ origin (nanotime)))))

(define/go (runtime.walltime sp)
  (define ms (current-milliseconds))
  (begin0 null
    (store-s64 (+ sp  8) (quotient ms 1000))
    (store-s32 (+ sp 16) (* (remainder ms 1000) 1000000))))

(define/go (runtime.scheduleTimeoutEvent . args))

(define/go (runtime.clearTimeoutEvent . args))

(define/go (runtime.getRandomData sp)
  (define arr (load-s64 (+ sp 8)))
  (define len (load-s64 (+ sp 16)))
  (begin0 null
    (memory-store! (ref "mem") arr (crypto-random-bytes len))))

(define/go (syscall/js.stringVal sp)
  (define str (load-string (+ sp 8)))
  (begin0 null
    (store-value (+ sp 24) str)))

(define/go (syscall/js.valueGet sp)
  (define t (load-value  (+ sp 8)))
  (define k (load-string (+ sp 16)))
  #;(printf "t: ~s k: ~s~n" t k)
  (define v (hash-ref t k))
  (define res-sp (car ((ref "getsp"))))
  (begin0 null
    (store-value (+ res-sp 32) v)))

(define/go (syscall/js.valueSet sp)
  (define t (load-value  (+ sp  8)))
  (define k (load-string (+ sp 16)))
  (define v (load-value  (+ sp 32)))
  (begin0 null
    (hash-set! t k v)))

(define/go (syscall/js.valueIndex sp)
  (define lst (load-value (+ sp 8)))
  (define idx (load-s64 (+ sp 16)))
  (define val (list-ref lst idx))
  #;(printf "lst=~s idx=~s val=~s~n" lst idx val)
  (begin0 null
    (store-value (+ sp 24) val)))

(define/go (syscall/js.valueSetIndex . args))

(define/go (syscall/js.valueCall sp)
  (begin0 null
    (with-handlers ([exn:fail?
                     (lambda (e)
                       ((error-display-handler) (exn-message e) e)
                       (define res-sp (car ((ref "getsp"))))
                       (store-value (+ res-sp 56) (exn-message e))
                       (store-u8 (+ res-sp 64) 0))])
      (define v (load-value (+ sp 8)))
      (define k (load-string (+ sp 16)))
      #;(printf "f: ~s k: ~s~n" v k)
      (define m (hash-ref v k))
      (define args (load-value-slice (+ sp 32)))
      (define res (apply m (cons v args)))
      (define res-sp (car ((ref "getsp"))))
      (store-value (+ res-sp 56) res)
      (store-u8 (+ res-sp 64) 1))))

(define/go (syscall/js.valueNew sp)
  (begin0 null
    (with-handlers ([exn:fail?
                     (lambda (e)
                       ((error-display-handler) (exn-message e) e)
                       (store-value (+ sp 40) (exn-message e))
                       (store-u8 (+ sp 48) 0))])
      (define v (load-value (+ sp 8)))
      (define args (load-value-slice (+ sp 16)))
      (define res (apply v args))
      (define res-sp (car ((ref "getsp"))))
      (store-value (+ res-sp 40) res)
      (store-u8 (+ res-sp 48) 1))))

(define/go (syscall/js.valueLength sp)
  (define val (load-value (+ sp 8)))
  (define len (inexact->exact (length val)))
  #;(printf "val=~s len=~s~n" val len)
  (begin0 null
    (store-s64 (+ sp 16) len)))

(define/go (syscall/js.valuePrepareString . args))
(define/go (syscall/js.valueLoadString . args))

(define/go (syscall/js.copyBytesToGo sp))

(define/go (syscall/js.copyBytesToJS sp)
  (define dst (load-value (+ sp 8)))
  (define src (load-slice (+ sp 16)))
  (define dst-buf (hash-ref dst "buf"))
  (for ([(b idx) (in-indexed src)])
    (bytes-set! dst-buf idx b))
  (begin0 null
    (store-s64 (+ sp 40) (bytes-length src))
    (store-u8 (+ sp 48) 1)))