-
-
Save Bogdanp/c4754c49dad09612a0bc3f84b342644b to your computer and use it in GitHub Desktop.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#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))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment