(in-package :cl-wasm)
(declaim (inline signed invsigned))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun signed (n i)
(if (and (<= 0 i)
(< i (expt 2 (1- n))))
i
(- i (expt 2 n))))
(defun invsigned (n i)
(if (< i 0)
(+ i (expt 2 n))
i)))
(defgeneric run-inst (client stack locals instruction argument)
(:method (client (stack list) (locals vector) (instruction (eql :get-local)) (argument number))
(cons (aref locals argument)
stack)))
(defmacro define-numeric-instruction (suffix (&optional (arg '(argument null))) &body body)
(let ((i32-name (alexandria:make-keyword (format nil "~a.~a" :i32 suffix)))
(i64-name (alexandria:make-keyword (format nil "~a.~a" :i64 suffix)))
(f32-name (alexandria:make-keyword (format nil "~a.~a" :f32 suffix)))
(f64-name (alexandria:make-keyword (format nil "~a.~a" :f64 suffix))))
(flet ((get-argument (type)
(case type
(:i32 (list (car arg)
(case (cadr arg)
(:type 'integer)
(t (cadr arg)))))
(:i64 (list (car arg)
(case (cadr arg)
(:type 'integer)
(t (cadr arg)))))
(:f32 (list (car arg)
(case (cadr arg)
(:type 'single-float)
(t (cadr arg)))))
(:f64 (list (car arg)
(case (cadr arg)
(:type 'double-float)
(t (cadr arg))))))))
`(macrolet ((numeric-dispatch (&body forms)
(cons 'or forms)))
(defmethod run-inst (client (stack list) (locals vector) (inst (eql ,i32-name)) ,(get-argument :i32))
(declare (optimize (speed 1) (safety 1)))
(macrolet ((numeric-case (type &body body)
(when (eql type :i32)
(cons 'progn body))))
(let ((numeric-type '(integer 0 #.(1- (expt 2 32))))
(size 32))
(declare (ignorable numeric-type size))
,@body)))
(defmethod run-inst (client (stack list) (locals vector) (inst (eql ,i64-name)) ,(get-argument :i64))
(declare (optimize (speed 1) (safety 1)))
(macrolet ((numeric-case (type &body body)
(when (eql type :i64)
(cons 'progn body))))
(let ((numeric-type '(integer 0 #.(1- (expt 2 64))))
(size 64))
(declare (ignorable numeric-type size))
,@body)))
(defmethod run-inst (client (stack list) (locals vector) (inst (eql ,f32-name)) ,(get-argument :f32))
(declare (optimize (speed 1) (safety 1)))
(macrolet ((numeric-case (type &body body)
(when (eql type :f32)
(cons 'progn body))))
(let ((numeric-type 'single-float)
(size 32))
(declare (ignorable numeric-type size))
,@body)))
(defmethod run-inst (client (stack list) (locals vector) (inst (eql ,f64-name)) ,(get-argument :f64))
(declare (optimize (speed 1) (safety 1)))
(macrolet ((numeric-case (type &body body)
(when (eql type :f64)
(cons 'progn body))))
(let ((numeric-type 'double-float)
(size 64))
(declare (ignorable numeric-type size))
,@body)))))))
(define-numeric-instruction add ()
(let ((result (+ (coerce (pop stack) numeric-type)
(coerce (pop stack) numeric-type))))
(cons (numeric-dispatch
(numeric-case :i32 (mod result #.(expt 2 32)))
(numeric-case :i64 (mod result #.(expt 2 64)))
(numeric-case :f32 result)
(numeric-case :f64 result))
stack)))
(define-numeric-instruction mul ()
(let ((result (* (coerce (pop stack) numeric-type)
(coerce (pop stack) numeric-type))))
(cons (numeric-dispatch
(numeric-case :i32 (mod result #.(expt 2 32)))
(numeric-case :i64 (mod result #.(expt 2 64)))
(numeric-case :f32 result)
(numeric-case :f64 result))
stack)))
(define-numeric-instruction const ((arg :type))
(cons (coerce arg numeric-type)
stack))
(define-numeric-instruction sub ()
(let ((i2 (pop stack))
(i1 (pop stack)))
(declare (ignorable i1 i2))
(cons (numeric-dispatch
(numeric-case :i32 (mod (+ (- (coerce i1 numeric-type)
(coerce i2 numeric-type))
#.(expt 2 32))
#.(expt 2 32)))
(numeric-case :i64 (mod (+ (- (coerce i1 numeric-type)
(coerce i2 numeric-type))
#.(expt 2 64))
#.(expt 2 64)))
(numeric-case :f32 (- (coerce i1 numeric-type)
(coerce i2 numeric-type)))
(numeric-case :f64 (- (coerce i1 numeric-type)
(coerce i2 numeric-type))))
stack)))
(define-numeric-instruction div_u ()
(let ((i2 (pop stack))
(i1 (pop stack)))
(declare (ignorable i1 i2))
(cons (numeric-dispatch
(numeric-case :i32 (mod (truncate (coerce i1 numeric-type)
(coerce i2 numeric-type))
#.(expt 2 32)))
(numeric-case :i64 (mod (truncate (coerce i1 numeric-type)
(coerce i2 numeric-type))
#.(expt 2 64)))
(numeric-case :f32 (error "floating div not implemented"))
(numeric-case :f64 (error "floating div not implemented")))
stack)))
(define-numeric-instruction div_s ()
(let* ((i2 (coerce (pop stack) numeric-type))
(j2 (signed size i2))
(i1 (coerce (pop stack) numeric-type))
(j1 (signed size i1)))
(declare (ignorable i1 i2 j1 j2))
(cons (numeric-dispatch
(numeric-case :i32 (if (/= (truncate i1 i2) #.(expt 2 31))
(invsigned 32 (truncate j1 j2))
(error "undefined result")))
(numeric-case :i64 (if (/= (truncate (coerce i1 numeric-type)
(coerce i2 numeric-type))
#.(expt 2 63))
(invsigned 64 (truncate j1 j2))
(error "undefined result")))
(numeric-case :f32 (error "floating div not implemented"))
(numeric-case :f64 (error "floating div not implemented")))
stack)))
(define-numeric-instruction rem_u ()
(let ((i2 (pop stack))
(i1 (pop stack)))
(declare (ignorable i1 i2))
(cons (numeric-dispatch
(numeric-case :i32 (mod (- (coerce i1 numeric-type)
(* (coerce i2 numeric-type)
(truncate i1 i2)))
#.(expt 2 32)))
(numeric-case :i64 (mod (- (coerce i1 numeric-type)
(* (coerce i2 numeric-type)
(truncate i1 i2)))
#.(expt 2 64)))
(numeric-case :f32 (error "floating rem not implemented"))
(numeric-case :f64 (error "floating rem not implemented")))
stack)))
(define-numeric-instruction rem_s ()
(let* ((i2 (pop stack))
(j2 (signed size i2))
(i1 (pop stack))
(j1 (signed size i1)))
(declare (ignorable i1 i2 j1 j2))
(cons (numeric-dispatch
(numeric-case :i32 (mod (- j1 (* j2
(truncate j1 j2)))
#.(expt 2 32)))
(numeric-case :i64 (mod (- j1 (* j2
(truncate j1 j2)))
#.(expt 2 64)))
(numeric-case :f32 (error "floating rem not implemented"))
(numeric-case :f64 (error "floating rem not implemented")))
stack)))
(define-numeric-instruction rem_s ()
(let* ((i2 (pop stack))
(j2 (signed size i2))
(i1 (pop stack))
(j1 (signed size i1)))
(declare (ignorable i1 i2 j1 j2))
(cons (numeric-dispatch
(numeric-case :i32 (mod (- (coerce j1 numeric-type)
(* (coerce j2 numeric-type)
(truncate j1 j2)))
#.(expt 2 32)))
(numeric-case :i64 (mod (- (coerce j1 numeric-type)
(* (coerce j2 numeric-type)
(truncate j1 j2)))
#.(expt 2 64)))
(numeric-case :f32 (error "floating rem not implemented"))
(numeric-case :f64 (error "floating rem not implemented")))
stack)))
(define-numeric-instruction and ()
(let* ((i2 (coerce (pop stack)
numeric-type))
(i1 (coerce (pop stack)
numeric-type)))
(declare (ignorable i1 i2))
(cons (numeric-dispatch
(numeric-case :i32 (logand #.(1- (expt 2 32))
(logand i1 i2)))
(numeric-case :i64 (logand #.(1- (expt 2 64))
(logand i1 i2)))
(numeric-case :f32 (error "floating rem not implemented"))
(numeric-case :f64 (error "floating rem not implemented")))
stack)))
(define-numeric-instruction or ()
(let* ((i2 (coerce (pop stack)
numeric-type))
(i1 (coerce (pop stack)
numeric-type)))
(declare (ignorable i1 i2))
(cons (numeric-dispatch
(numeric-case :i32 (logand #.(1- (expt 2 32))
(logior i1 i2)))
(numeric-case :i64 (logand #.(1- (expt 2 64))
(logior i1 i2)))
(numeric-case :f32 (error "floating rem not implemented"))
(numeric-case :f64 (error "floating rem not implemented")))
stack)))
(define-numeric-instruction xor ()
(let* ((i2 (coerce (pop stack)
numeric-type))
(i1 (coerce (pop stack)
numeric-type)))
(declare (ignorable i1 i2))
(cons (numeric-dispatch
(numeric-case :i32 (logand #.(1- (expt 2 32))
(logxor i1 i2)))
(numeric-case :i64 (logand #.(1- (expt 2 64))
(logxor i1 i2)))
(numeric-case :f32 (error "floating rem not implemented"))
(numeric-case :f64 (error "floating rem not implemented")))
stack)))
(define-numeric-instruction shl ()
(let* ((i2 (coerce (pop stack)
numeric-type))
(i1 (coerce (pop stack)
numeric-type)))
(declare (ignorable i1 i2))
(cons (numeric-dispatch
(numeric-case :i32 (mod (ash i1 i2)
#.(expt 2 32)))
(numeric-case :i64 (mod (ash i1 i2)
#.(expt 2 64)))
(numeric-case :f32 (error "floating rem not implemented"))
(numeric-case :f64 (error "floating rem not implemented")))
stack)))
(define-numeric-instruction shr_u ()
(let* ((i2 (coerce (pop stack)
numeric-type))
(i1 (coerce (pop stack)
numeric-type)))
(declare (ignorable i1 i2))
(cons (numeric-dispatch
(numeric-case :i32 (mod (ash i1 (- i2))
#.(expt 2 32)))
(numeric-case :i64 (mod (ash i1 (- i2))
#.(expt 2 64)))
(numeric-case :f32 (error "floating rem not implemented"))
(numeric-case :f64 (error "floating rem not implemented")))
stack)))
(define-numeric-instruction shr_s ()
(let* ((i2 (coerce (pop stack)
numeric-type))
(i1 (coerce (pop stack)
numeric-type)))
(declare (ignorable i1 i2))
(cons (numeric-dispatch
(numeric-case :i32 (mod (ash (logand -1 i1)
(- i2))
#.(expt 2 32)))
(numeric-case :i64 (mod (ash (logand -1 i1)
(- i2))
#.(expt 2 64)))
(numeric-case :f32 (error "floating rem not implemented"))
(numeric-case :f64 (error "floating rem not implemented")))
stack)))
(fw.lu:defclass+ tracer ()
((%level :initarg :level :accessor level)))
(fw.lu:defclass+ wat-emitter ()
((%level :initarg :level :accessor level)))
(defvar *client*
(tracer 0))
(defmethod run-inst :around ((client tracer) stack locals instruction argument)
(format t "~&~vt> ~s ~s ~s~%~vt~8t|~{~s~^ ~}|"
(level client) locals instruction argument
(level client) (reverse stack))
(incf (level client))
(unwind-protect
(let ((out (call-next-method)))
(prog1 out
(format t "~&~vt<~8t|~{~s~^ ~}|~%"
(level client) (reverse out))))
(decf (level client))))
(defmethod run-inst :around ((client wat-emitter) stack locals instruction argument)
(incf (level client))
(unwind-protect
(let ((out (call-next-method)))
(let ((*print-case* :downcase))
(format t "~&~4t~a~:[~; ~:*~a~]" instruction argument))
out)
(decf (level client))))
(defgeneric pre-interpret (client)
(:method (client)))
(defgeneric post-interpret (client)
(:method (client)))
(defmethod pre-interpret ((client wat-emitter))
(format t "~&(module (func $it (result i32)"))
(defmethod post-interpret ((client wat-emitter))
(format t ")
(export \"it\" (func $it)))~%"))
(defun interpret (instructions locals)
(pre-interpret *client*)
(let ((stack ()))
(loop for (instruction argument) in instructions
do (setf stack
(run-inst *client* stack locals instruction argument)))
(post-interpret *client*)
stack))
(defun test-responder ()
(spinneret:with-html-string
(:html
(:body
(:script :src "https://localhost/~elangley/libwabt.js")
(:script
(ps:ps
(let* ((ws (ps:new (-web-socket "ws://localhost:5001/ws")))
(compile-wat (lambda (m)
(lambda (wabt)
(ps:chain ws
(send
(+ "result "
(ps:chain
(setf (ps:@ window module)
(ps:new
((ps:@ -web-assembly -instance)
(ps:new
((ps:@ -web-assembly -module)
(ps:chain wabt
(parse-wat "foo.wast"
(ps:@ m data))
(to-binary
(ps:create log ps:t
write_debug_names ps:t))
buffer))))))
exports
(it))))))))
(message-handler (lambda (m)
(ps:chain console (log (ps:@ m data)))
(ps:chain (ps:new (-wabt-module))
(then (compile-wat m))))))
(ps:chain ws
(add-event-listener "message" message-handler))
(ps:chain ws
(add-event-listener "close"
(lambda (_)
(setf ws (ps:new (-web-socket "ws://localhost:5001/ws")))
(ps:chain ws
(add-event-listener "message" message-handler))))))))))))
(defclass wasm-session (hunchensocket:websocket-resource)
((name :initarg :name :reader name)))
(defvar *wasm-sessions*
(make-array 10 :fill-pointer 0 :adjustable t))
(defmethod hunchensocket:text-message-received ((resource wasm-session) client message)
(format t "~&in: ~a~%" message))
(defun find-wasm-session (request)
(or (find (hunchentoot:script-name request)
*wasm-sessions*
:test #'string=
:key 'name)
(fw.lu:prog1-bind (session (make-instance 'wasm-session
:name (hunchentoot:script-name request)))
(vector-push-extend session
*wasm-sessions*))))
(pushnew 'find-wasm-session
hunchensocket:*websocket-dispatch-table*)
(defun broadcast (session message)
(loop for peer in (hunchensocket:clients session)
do (hunchensocket:send-text-message peer message)))
(defclass my-acceptor (hunchensocket:websocket-acceptor)
())
(defmethod hunchentoot:acceptor-dispatch-request ((acceptor my-acceptor) request)
(if (string= "/" (hunchentoot:script-name request))
(test-responder)
(call-next-method)))
(defvar *app*)
(defvar *handler*)
(defun demo ()
(let ((app (make-instance 'my-acceptor :port 5001)))
(values (hunchentoot:start app)
app)))
(defun go* ()
(setf (values *handler* *app*)
(demo)))
#|
i32.clz
i32.ctz
i32.popcnt
i32.shl
i32.shr_s
i32.shr_u
i32.rotl
i32.rotr
i64.clz
i64.ctz
i64.popcnt
i64.shl
i64.shr_s
i64.shr_u
i64.rotl
i64.rotr
f32.abs
f32.neg
f32.ceil
f32.floor
f32.trunc
f32.nearest
f32.sqrt
f32.div
f32.min
f32.max
f32.copysign
f64.abs
f64.neg
f64.ceil
f64.floor
f64.trunc
f64.nearest
f64.sqrt
f64.div
f64.min
f64.max
f64.copysign
i32.eqz
i32.eq
i32.ne
i32.lt_s
i32.lt_u
i32.gt_s
i32.gt_u
i32.le_s
i32.le_u
i32.ge_s
i32.ge_u
i64.eqz
i64.eq
i64.ne
i64.lt_s
i64.lt_u
i64.gt_s
i64.gt_u
i64.le_s
i64.le_u
i64.ge_s
i64.ge_u
f32.eq
f32.ne
f32.lt
f32.gt
f32.le
f32.ge
f64.eq
f64.ne
f64.lt
f64.gt
f64.le
f64.ge
i32.wrap_i64
i32.trunc_f32_s
i32.trunc_f32_u
i32.trunc_f64_s
i32.trunc_f64_u
i64.extend_i32_s
i64.extend_i32_u
i64.trunc_f32_s
i64.trunc_f32_u
i64.trunc_f64_s
i64.trunc_f64_u
f32.convert_i32_s
f32.convert_i32_u
f32.convert_i64_s
f32.convert_i64_u
f32.demote_f64
f64.convert_i32_s
f64.convert_i32_u
f64.convert_i64_s
f64.convert_i64_u
f64.promote_f32
i32.reinterpret_f32
i64.reinterpret_f64
f32.reinterpret_i32
f64.reinterpret_i64
|#