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