Browse code
feat: new instructions, improve ws server
Ed Langley authored on 29/10/2020 21:53:21Showing 2 changed files
| ... | ... |
@@ -1,14 +1,16 @@ |
| 1 | 1 |
(in-package :cl-wasm) |
| 2 | 2 |
|
| 3 |
-(defun signed (n i) |
|
| 4 |
- (if (and (<= 0 i) |
|
| 5 |
- (< i (expt 2 (1- n)))) |
|
| 6 |
- i |
|
| 7 |
- (- i (expt 2 n)))) |
|
| 8 |
-(defun invsigned (n i) |
|
| 9 |
- (if (< i 0) |
|
| 10 |
- (+ i (expt 2 n)) |
|
| 11 |
- i)) |
|
| 3 |
+(declaim (inline signed invsigned)) |
|
| 4 |
+(eval-when (:compile-toplevel :load-toplevel :execute) |
|
| 5 |
+ (defun signed (n i) |
|
| 6 |
+ (if (and (<= 0 i) |
|
| 7 |
+ (< i (expt 2 (1- n)))) |
|
| 8 |
+ i |
|
| 9 |
+ (- i (expt 2 n)))) |
|
| 10 |
+ (defun invsigned (n i) |
|
| 11 |
+ (if (< i 0) |
|
| 12 |
+ (+ i (expt 2 n)) |
|
| 13 |
+ i))) |
|
| 12 | 14 |
|
| 13 | 15 |
(defgeneric run-inst (client stack locals instruction argument) |
| 14 | 16 |
(:method (client (stack list) (locals vector) (instruction (eql :get-local)) (argument number)) |
| ... | ... |
@@ -41,7 +43,7 @@ |
| 41 | 43 |
`(macrolet ((numeric-dispatch (&body forms) |
| 42 | 44 |
(cons 'or forms))) |
| 43 | 45 |
(defmethod run-inst (client (stack list) (locals vector) (inst (eql ,i32-name)) ,(get-argument :i32)) |
| 44 |
- (declare (optimize (speed 3) (safety 1))) |
|
| 46 |
+ (declare (optimize (speed 1) (safety 1))) |
|
| 45 | 47 |
(macrolet ((numeric-case (type &body body) |
| 46 | 48 |
(when (eql type :i32) |
| 47 | 49 |
(cons 'progn body)))) |
| ... | ... |
@@ -50,16 +52,16 @@ |
| 50 | 52 |
(declare (ignorable numeric-type size)) |
| 51 | 53 |
,@body))) |
| 52 | 54 |
(defmethod run-inst (client (stack list) (locals vector) (inst (eql ,i64-name)) ,(get-argument :i64)) |
| 53 |
- (declare (optimize (speed 3) (safety 1))) |
|
| 55 |
+ (declare (optimize (speed 1) (safety 1))) |
|
| 54 | 56 |
(macrolet ((numeric-case (type &body body) |
| 55 | 57 |
(when (eql type :i64) |
| 56 | 58 |
(cons 'progn body)))) |
| 57 |
- (let ((numeric-type '(integer #.(1- (expt 2 64)))) |
|
| 59 |
+ (let ((numeric-type '(integer 0 #.(1- (expt 2 64)))) |
|
| 58 | 60 |
(size 64)) |
| 59 | 61 |
(declare (ignorable numeric-type size)) |
| 60 | 62 |
,@body))) |
| 61 | 63 |
(defmethod run-inst (client (stack list) (locals vector) (inst (eql ,f32-name)) ,(get-argument :f32)) |
| 62 |
- (declare (optimize (speed 3) (safety 1))) |
|
| 64 |
+ (declare (optimize (speed 1) (safety 1))) |
|
| 63 | 65 |
(macrolet ((numeric-case (type &body body) |
| 64 | 66 |
(when (eql type :f32) |
| 65 | 67 |
(cons 'progn body)))) |
| ... | ... |
@@ -68,7 +70,7 @@ |
| 68 | 70 |
(declare (ignorable numeric-type size)) |
| 69 | 71 |
,@body))) |
| 70 | 72 |
(defmethod run-inst (client (stack list) (locals vector) (inst (eql ,f64-name)) ,(get-argument :f64)) |
| 71 |
- (declare (optimize (speed 3) (safety 1))) |
|
| 73 |
+ (declare (optimize (speed 1) (safety 1))) |
|
| 72 | 74 |
(macrolet ((numeric-case (type &body body) |
| 73 | 75 |
(when (eql type :f64) |
| 74 | 76 |
(cons 'progn body)))) |
| ... | ... |
@@ -137,24 +139,18 @@ |
| 137 | 139 |
|
| 138 | 140 |
(define-numeric-instruction div_s () |
| 139 | 141 |
(let* ((i2 (coerce (pop stack) numeric-type)) |
| 140 |
- (j2 (coerce (signed size i2) numeric-type)) |
|
| 142 |
+ (j2 (signed size i2)) |
|
| 141 | 143 |
(i1 (coerce (pop stack) numeric-type)) |
| 142 |
- (j1 (coerce (signed size i1) numeric-type))) |
|
| 144 |
+ (j1 (signed size i1))) |
|
| 143 | 145 |
(declare (ignorable i1 i2 j1 j2)) |
| 144 | 146 |
(cons (numeric-dispatch |
| 145 |
- (numeric-case :i32 (if (/= (truncate (coerce i1 numeric-type) |
|
| 146 |
- (coerce i2 numeric-type)) |
|
| 147 |
- #.(expt 2 31)) |
|
| 148 |
- (invsigned 32 |
|
| 149 |
- (truncate (coerce j1 numeric-type) |
|
| 150 |
- (coerce j2 numeric-type))) |
|
| 147 |
+ (numeric-case :i32 (if (/= (truncate i1 i2) #.(expt 2 31)) |
|
| 148 |
+ (invsigned 32 (truncate j1 j2)) |
|
| 151 | 149 |
(error "undefined result"))) |
| 152 | 150 |
(numeric-case :i64 (if (/= (truncate (coerce i1 numeric-type) |
| 153 | 151 |
(coerce i2 numeric-type)) |
| 154 | 152 |
#.(expt 2 63)) |
| 155 |
- (invsigned 64 |
|
| 156 |
- (truncate (coerce j1 numeric-type) |
|
| 157 |
- (coerce j2 numeric-type))) |
|
| 153 |
+ (invsigned 64 (truncate j1 j2)) |
|
| 158 | 154 |
(error "undefined result"))) |
| 159 | 155 |
(numeric-case :f32 (error "floating div not implemented")) |
| 160 | 156 |
(numeric-case :f64 (error "floating div not implemented"))) |
| ... | ... |
@@ -184,13 +180,11 @@ |
| 184 | 180 |
(j1 (signed size i1))) |
| 185 | 181 |
(declare (ignorable i1 i2 j1 j2)) |
| 186 | 182 |
(cons (numeric-dispatch |
| 187 |
- (numeric-case :i32 (mod (- (coerce j1 numeric-type) |
|
| 188 |
- (* (coerce j2 numeric-type) |
|
| 189 |
- (truncate j1 j2))) |
|
| 183 |
+ (numeric-case :i32 (mod (- j1 (* j2 |
|
| 184 |
+ (truncate j1 j2))) |
|
| 190 | 185 |
#.(expt 2 32))) |
| 191 |
- (numeric-case :i64 (mod (- (coerce j1 numeric-type) |
|
| 192 |
- (* (coerce j2 numeric-type) |
|
| 193 |
- (truncate j1 j2))) |
|
| 186 |
+ (numeric-case :i64 (mod (- j1 (* j2 |
|
| 187 |
+ (truncate j1 j2))) |
|
| 194 | 188 |
#.(expt 2 64))) |
| 195 | 189 |
(numeric-case :f32 (error "floating rem not implemented")) |
| 196 | 190 |
(numeric-case :f64 (error "floating rem not implemented"))) |
| ... | ... |
@@ -260,6 +254,53 @@ |
| 260 | 254 |
(numeric-case :f64 (error "floating rem not implemented"))) |
| 261 | 255 |
stack))) |
| 262 | 256 |
|
| 257 |
+(define-numeric-instruction shl () |
|
| 258 |
+ (let* ((i2 (coerce (pop stack) |
|
| 259 |
+ numeric-type)) |
|
| 260 |
+ (i1 (coerce (pop stack) |
|
| 261 |
+ numeric-type))) |
|
| 262 |
+ (declare (ignorable i1 i2)) |
|
| 263 |
+ (cons (numeric-dispatch |
|
| 264 |
+ (numeric-case :i32 (mod (ash i1 i2) |
|
| 265 |
+ #.(expt 2 32))) |
|
| 266 |
+ (numeric-case :i64 (mod (ash i1 i2) |
|
| 267 |
+ #.(expt 2 64))) |
|
| 268 |
+ (numeric-case :f32 (error "floating rem not implemented")) |
|
| 269 |
+ (numeric-case :f64 (error "floating rem not implemented"))) |
|
| 270 |
+ stack))) |
|
| 271 |
+ |
|
| 272 |
+(define-numeric-instruction shr_u () |
|
| 273 |
+ (let* ((i2 (coerce (pop stack) |
|
| 274 |
+ numeric-type)) |
|
| 275 |
+ (i1 (coerce (pop stack) |
|
| 276 |
+ numeric-type))) |
|
| 277 |
+ (declare (ignorable i1 i2)) |
|
| 278 |
+ (cons (numeric-dispatch |
|
| 279 |
+ (numeric-case :i32 (mod (ash i1 (- i2)) |
|
| 280 |
+ #.(expt 2 32))) |
|
| 281 |
+ (numeric-case :i64 (mod (ash i1 (- i2)) |
|
| 282 |
+ #.(expt 2 64))) |
|
| 283 |
+ (numeric-case :f32 (error "floating rem not implemented")) |
|
| 284 |
+ (numeric-case :f64 (error "floating rem not implemented"))) |
|
| 285 |
+ stack))) |
|
| 286 |
+ |
|
| 287 |
+(define-numeric-instruction shr_s () |
|
| 288 |
+ (let* ((i2 (coerce (pop stack) |
|
| 289 |
+ numeric-type)) |
|
| 290 |
+ (i1 (coerce (pop stack) |
|
| 291 |
+ numeric-type))) |
|
| 292 |
+ (declare (ignorable i1 i2)) |
|
| 293 |
+ (cons (numeric-dispatch |
|
| 294 |
+ (numeric-case :i32 (mod (ash (logand -1 i1) |
|
| 295 |
+ (- i2)) |
|
| 296 |
+ #.(expt 2 32))) |
|
| 297 |
+ (numeric-case :i64 (mod (ash (logand -1 i1) |
|
| 298 |
+ (- i2)) |
|
| 299 |
+ #.(expt 2 64))) |
|
| 300 |
+ (numeric-case :f32 (error "floating rem not implemented")) |
|
| 301 |
+ (numeric-case :f64 (error "floating rem not implemented"))) |
|
| 302 |
+ stack))) |
|
| 303 |
+ |
|
| 263 | 304 |
(fw.lu:defclass+ tracer () |
| 264 | 305 |
((%level :initarg :level :accessor level))) |
| 265 | 306 |
(fw.lu:defclass+ wat-emitter () |
| ... | ... |
@@ -314,30 +355,193 @@ |
| 314 | 355 |
(:html |
| 315 | 356 |
(:body |
| 316 | 357 |
(:script :src "https://localhost/~elangley/libwabt.js") |
| 317 |
- (:script |
|
| 318 |
- (:raw |
|
| 319 |
- (format nil "v=`~a`;WabtModule().then(wabt => window.module = new WebAssembly.Instance(new WebAssembly.Module(wabt.parseWat('foo.wast', v).toBinary({log:true,write_debug_names:true}).buffer)));"
|
|
| 320 |
- (cl-ppcre:regex-replace-all "[\"]" |
|
| 321 |
- (with-output-to-string (*standard-output*) |
|
| 322 |
- (interpret '((:i32.const #.(invsigned 32 -4)) |
|
| 323 |
- (:i32.const #b10101010101010111) |
|
| 324 |
- (:i32.and nil) |
|
| 325 |
- ) |
|
| 326 |
- (vector 10))) |
|
| 327 |
- "\\\"")))))))) |
|
| 358 |
+ (:script |
|
| 359 |
+ (ps:ps |
|
| 360 |
+ (let* ((ws (ps:new (-web-socket "ws://localhost:5001/ws"))) |
|
| 361 |
+ (compile-wat (lambda (m) |
|
| 362 |
+ (lambda (wabt) |
|
| 363 |
+ (ps:chain ws |
|
| 364 |
+ (send |
|
| 365 |
+ (+ "result " |
|
| 366 |
+ (ps:chain |
|
| 367 |
+ (setf (ps:@ window module) |
|
| 368 |
+ (ps:new |
|
| 369 |
+ ((ps:@ -web-assembly -instance) |
|
| 370 |
+ (ps:new |
|
| 371 |
+ ((ps:@ -web-assembly -module) |
|
| 372 |
+ (ps:chain wabt |
|
| 373 |
+ (parse-wat "foo.wast" |
|
| 374 |
+ (ps:@ m data)) |
|
| 375 |
+ (to-binary |
|
| 376 |
+ (ps:create log ps:t |
|
| 377 |
+ write_debug_names ps:t)) |
|
| 378 |
+ buffer)))))) |
|
| 379 |
+ exports |
|
| 380 |
+ (it)))))))) |
|
| 381 |
+ (message-handler (lambda (m) |
|
| 382 |
+ (ps:chain console (log (ps:@ m data))) |
|
| 383 |
+ (ps:chain (ps:new (-wabt-module)) |
|
| 384 |
+ (then (compile-wat m)))))) |
|
| 385 |
+ (ps:chain ws |
|
| 386 |
+ (add-event-listener "message" message-handler)) |
|
| 387 |
+ (ps:chain ws |
|
| 388 |
+ (add-event-listener "close" |
|
| 389 |
+ (lambda (_) |
|
| 390 |
+ (setf ws (ps:new (-web-socket "ws://localhost:5001/ws"))) |
|
| 391 |
+ (ps:chain ws |
|
| 392 |
+ (add-event-listener "message" message-handler)))))))))))) |
|
| 393 |
+ |
|
| 394 |
+(defclass wasm-session (hunchensocket:websocket-resource) |
|
| 395 |
+ ((name :initarg :name :reader name))) |
|
| 396 |
+ |
|
| 397 |
+(defvar *wasm-sessions* |
|
| 398 |
+ (make-array 10 :fill-pointer 0 :adjustable t)) |
|
| 399 |
+ |
|
| 400 |
+(defmethod hunchensocket:text-message-received ((resource wasm-session) client message) |
|
| 401 |
+ (format t "~&in: ~a~%" message)) |
|
| 402 |
+ |
|
| 403 |
+(defun find-wasm-session (request) |
|
| 404 |
+ (or (find (hunchentoot:script-name request) |
|
| 405 |
+ *wasm-sessions* |
|
| 406 |
+ :test #'string= |
|
| 407 |
+ :key 'name) |
|
| 408 |
+ (fw.lu:prog1-bind (session (make-instance 'wasm-session |
|
| 409 |
+ :name (hunchentoot:script-name request))) |
|
| 410 |
+ (vector-push-extend session |
|
| 411 |
+ *wasm-sessions*)))) |
|
| 412 |
+ |
|
| 413 |
+(pushnew 'find-wasm-session |
|
| 414 |
+ hunchensocket:*websocket-dispatch-table*) |
|
| 415 |
+ |
|
| 416 |
+(defun broadcast (session message) |
|
| 417 |
+ (loop for peer in (hunchensocket:clients session) |
|
| 418 |
+ do (hunchensocket:send-text-message peer message))) |
|
| 419 |
+ |
|
| 420 |
+(defclass my-acceptor (hunchensocket:websocket-acceptor) |
|
| 421 |
+ ()) |
|
| 422 |
+ |
|
| 423 |
+(defmethod hunchentoot:acceptor-dispatch-request ((acceptor my-acceptor) request) |
|
| 424 |
+ (if (string= "/" (hunchentoot:script-name request)) |
|
| 425 |
+ (test-responder) |
|
| 426 |
+ (call-next-method))) |
|
| 328 | 427 |
|
| 329 | 428 |
(defvar *app*) |
| 330 | 429 |
(defvar *handler*) |
| 430 |
+ |
|
| 331 | 431 |
(defun demo () |
| 332 |
- (let ((app (make-instance 'ningle:<app>))) |
|
| 333 |
- (setf (ningle:route app "/") |
|
| 334 |
- (lambda (params) |
|
| 335 |
- params |
|
| 336 |
- (list 200 () (list (test-responder))))) |
|
| 337 |
- (values (clack:clackup app |
|
| 338 |
- :port 5001) |
|
| 432 |
+ (let ((app (make-instance 'my-acceptor :port 5001))) |
|
| 433 |
+ (values (hunchentoot:start app) |
|
| 339 | 434 |
app))) |
| 340 | 435 |
|
| 341 | 436 |
(defun go* () |
| 342 | 437 |
(setf (values *handler* *app*) |
| 343 | 438 |
(demo))) |
| 439 |
+ |
|
| 440 |
+#| |
|
| 441 |
+i32.clz |
|
| 442 |
+i32.ctz |
|
| 443 |
+i32.popcnt |
|
| 444 |
+i32.shl |
|
| 445 |
+i32.shr_s |
|
| 446 |
+i32.shr_u |
|
| 447 |
+i32.rotl |
|
| 448 |
+i32.rotr |
|
| 449 |
+ |
|
| 450 |
+i64.clz |
|
| 451 |
+i64.ctz |
|
| 452 |
+i64.popcnt |
|
| 453 |
+i64.shl |
|
| 454 |
+i64.shr_s |
|
| 455 |
+i64.shr_u |
|
| 456 |
+i64.rotl |
|
| 457 |
+i64.rotr |
|
| 458 |
+ |
|
| 459 |
+f32.abs |
|
| 460 |
+f32.neg |
|
| 461 |
+f32.ceil |
|
| 462 |
+f32.floor |
|
| 463 |
+f32.trunc |
|
| 464 |
+f32.nearest |
|
| 465 |
+f32.sqrt |
|
| 466 |
+f32.div |
|
| 467 |
+f32.min |
|
| 468 |
+f32.max |
|
| 469 |
+f32.copysign |
|
| 470 |
+ |
|
| 471 |
+f64.abs |
|
| 472 |
+f64.neg |
|
| 473 |
+f64.ceil |
|
| 474 |
+f64.floor |
|
| 475 |
+f64.trunc |
|
| 476 |
+f64.nearest |
|
| 477 |
+f64.sqrt |
|
| 478 |
+f64.div |
|
| 479 |
+f64.min |
|
| 480 |
+f64.max |
|
| 481 |
+f64.copysign |
|
| 482 |
+ |
|
| 483 |
+i32.eqz |
|
| 484 |
+i32.eq |
|
| 485 |
+i32.ne |
|
| 486 |
+i32.lt_s |
|
| 487 |
+i32.lt_u |
|
| 488 |
+i32.gt_s |
|
| 489 |
+i32.gt_u |
|
| 490 |
+i32.le_s |
|
| 491 |
+i32.le_u |
|
| 492 |
+i32.ge_s |
|
| 493 |
+i32.ge_u |
|
| 494 |
+ |
|
| 495 |
+i64.eqz |
|
| 496 |
+i64.eq |
|
| 497 |
+i64.ne |
|
| 498 |
+i64.lt_s |
|
| 499 |
+i64.lt_u |
|
| 500 |
+i64.gt_s |
|
| 501 |
+i64.gt_u |
|
| 502 |
+i64.le_s |
|
| 503 |
+i64.le_u |
|
| 504 |
+i64.ge_s |
|
| 505 |
+i64.ge_u |
|
| 506 |
+ |
|
| 507 |
+f32.eq |
|
| 508 |
+f32.ne |
|
| 509 |
+f32.lt |
|
| 510 |
+f32.gt |
|
| 511 |
+f32.le |
|
| 512 |
+f32.ge |
|
| 513 |
+ |
|
| 514 |
+f64.eq |
|
| 515 |
+f64.ne |
|
| 516 |
+f64.lt |
|
| 517 |
+f64.gt |
|
| 518 |
+f64.le |
|
| 519 |
+f64.ge |
|
| 520 |
+ |
|
| 521 |
+ |
|
| 522 |
+i32.wrap_i64 |
|
| 523 |
+i32.trunc_f32_s |
|
| 524 |
+i32.trunc_f32_u |
|
| 525 |
+i32.trunc_f64_s |
|
| 526 |
+i32.trunc_f64_u |
|
| 527 |
+i64.extend_i32_s |
|
| 528 |
+i64.extend_i32_u |
|
| 529 |
+i64.trunc_f32_s |
|
| 530 |
+i64.trunc_f32_u |
|
| 531 |
+i64.trunc_f64_s |
|
| 532 |
+i64.trunc_f64_u |
|
| 533 |
+f32.convert_i32_s |
|
| 534 |
+f32.convert_i32_u |
|
| 535 |
+f32.convert_i64_s |
|
| 536 |
+f32.convert_i64_u |
|
| 537 |
+f32.demote_f64 |
|
| 538 |
+f64.convert_i32_s |
|
| 539 |
+f64.convert_i32_u |
|
| 540 |
+f64.convert_i64_s |
|
| 541 |
+f64.convert_i64_u |
|
| 542 |
+f64.promote_f32 |
|
| 543 |
+i32.reinterpret_f32 |
|
| 544 |
+i64.reinterpret_f64 |
|
| 545 |
+f32.reinterpret_i32 |
|
| 546 |
+f64.reinterpret_i64 |
|
| 547 |
+|# |