Create assembler driver script for recording word addresses

This will allow the profiler to sample the current return stack and
instruction pointer.  It can't just use the ip and rsp globals
directly, as I had initially planned, since these cannot be sent
in between threads.

README.md

@@ -1,31 +1,24 @@
 # Wipforth
 
-Wipforth is a simple Forth implementation that runs in the WebAssembly
-virtual machine.  It does I/O via memory-mapped peripherals, which are
-emulated in JavaScript.
+Wipforth is a Forth implementation that runs in the WebAssembly
+virtual machine.  The system is bootstrapped from source on page load:
+the only non-text file is the favicon :)
 
-- For the Forth kernel, see [wipforth.wat](./wipforth.wat)
-- For the JavaScript emulator, see [emu.js](./emu.js)
-- For the Forth prelude, which is loaded at start-up, see
-  [prelude.f](./prelude.f)
+I/O is done via memory-mapped peripherals, which are emulated in
+JavaScript.
+
+- For the Forth kernel, see [wipforth.ws](./wipforth.ws)
+- For the emulator, see [emu.js](./emu.js)
+- For the assembler, see [asm.js](./asm.js)
+- For the prelude (Forth code loaded right after the kernel boots),
+  see [prelude.f](./prelude.f)
 - For a description of the peripherals, see the
   [Peripherals](#peripherals) section below.
 
 ## Building and Running Locally
 
-You'll need:
-
-- [WABT](https://github.com/WebAssembly/wabt)
-- [Guile](https://www.gnu.org/software/guile/) (or bring your own HTTP
-  server -- see note below)
-
-To run, first compile the WebAssembly module:
-
-```
-wat2wasm --enable-threads wipforth.wat
-```
-
-Then run the development server:
+There's a [Guile](https://www.gnu.org/software/guile/) script in the
+repo you can use for this:
 
 ```
 guile server.scm
@@ -34,14 +27,46 @@ guile server.scm
 You should then be able to open <http://localhost:8080> in a browser
 and use the system from there.
 
-**NOTE**: The server is very simple and just serves the files with the
-cross-origin isolation headers required for `SharedMemoryBuffer` use.
-You could use any HTTP server that sets these headers.
+However, since everything is bootstrapped on the client, basically any
+HTTP server will do as long as it sets the appropriate response
+headers for `SharedMemoryBuffer` use:
 
-You should **definitely not** use the development server to serve the
-application on the open internet; I just hacked it together for
-testing on localhost during development and it's probably hilariously
-insecure.
+- `Cross-Origin-Opener-Policy: same-origin`
+- `Cross-Origin-Embedder-Policy: require-corp`
+
+So, if you don't have Guile on your system you can use something else
+like Python's `http.server`.
+
+**NOTE**: You should **definitely not** use `server.scm` to serve the
+application on the open internet or anything like that; I just hacked
+it together for testing on localhost during development and it's
+probably hilariously insecure.
+
+## End-to-End Tests
+
+There's a (fairly minimal at the moment) end-to-end test suite defined
+in [tests.scm](./tests.scm).  To run it you'll need:
+
+- [Guile](https://www.gnu.org/software/guile/) again (no substitute
+  this time, sorry)
+- [guile-json](https://github.com/aconchillo/guile-json)
+- Firefox
+
+I'm also pretty sure it won't work on a non-POSIX system, though I
+haven't tried it.
+
+Given that's all sorted, you should be able to run:
+
+```
+guile tests.scm
+```
+
+It will print a JUnit XML report to standard out.  You can
+pretty-print it with `xmllint` if you have it installed:
+
+```
+guile tests.scm | xmllint --format -
+```
 
 ## Peripherals
 

boot.js

@@ -1,7 +1,26 @@
+import { Assembler } from './asm.js';
+
+const assemble = (async () => {
+	const asm = new Assembler();
+	const resp = await fetch('wipforth.ws');
+	for await (const chunk of resp.body) {
+		asm.push(chunk);
+	}
+	return asm.wasm();
+})();
+
 self.onmessage = async (e) => {
-	const exports = { emu: { mem: e.data } };
-	const mod = await WebAssembly.instantiateStreaming(
-		fetch('wipforth.wasm'), exports)
-	mod.instance.exports.reset();
-	console.log('System halt');
+	switch (e.data.type) {
+	case "load":
+		const exports = { emu: { mem: e.data.mem } };
+		const wasm = await assemble;
+		self.mod = await WebAssembly.instantiate(wasm, exports);
+		await self.postMessage('ready');
+		break;
+
+	case "boot":
+		self.mod.instance.exports.reset();
+		console.log('System halt');
+		break;
+	}
 };

deploy-manifest.conf

@@ -0,0 +1,6 @@
+boot.js
+emu.js
+index.html
+prelude.f
+styles.css
+wipforth.ws

e2e/marionette.scm

@@ -1,4 +1,4 @@
-(define-module (wipforth marionette)
+(define-module (e2e marionette)
   #:export (with-marionette
 			start-firefox
 			close-firefox
@@ -25,8 +25,11 @@
 		(when pid (close-firefox pid))))))
 
 (define (start-firefox)
-  (let* ((i/o (pipe))
-		 (pid (spawn "firefox" '("firefox" "--marionette" "--headless")
+  (let* ((profile-dir (mkdtemp "/tmp/marionette-XXXXXX"))
+		 (i/o (pipe))
+		 (pid (spawn "firefox"
+					 `("firefox" "--marionette" "--headless"
+					   "--profile" ,profile-dir "about:blank")
 					 #:output (cdr i/o)
 					 #:error (cdr i/o))))
 	(let loop ((line (read-line (car i/o))))

e2e/testing.scm

@@ -0,0 +1,71 @@
+(define-module (e2e testing)
+  #:export (assert define-test run-tests run-tests-with-cleanup))
+
+(use-modules
+ (sxml simple)
+ (srfi srfi-1))
+
+(define *tests* (make-fluid '()))
+
+(define (assert condition . args)
+  (unless condition
+	(let ((msg (if (null? args) "Assertion failed" (car args))))
+	  (raise-exception `(assertion-failed . ,msg)))))
+
+(define-syntax-rule (define-test name body ...)
+  (fluid-set!
+   *tests*
+   (append (fluid-ref *tests*)
+		   (list (cons 'name (lambda () body ...))))))
+
+(define (fail-handler ex)
+  (if (and (pair? ex) (eq? 'assertion-failed (car ex)))
+	  (cons 'fail (cdr ex))
+	  (cons 'error (format #f "~a" ex))))
+
+(define (run-test test)
+  (cons (car test)
+		(with-exception-handler fail-handler
+		  (lambda ()
+			((cdr test))
+			'pass)
+		  #:unwind? #t)))
+
+(define (fail? result)
+  (and (pair? (cdr result))
+	   (eq? 'fail (cadr result))))
+
+(define (error? result)
+  (and (pair? (cdr result))
+	   (eq? 'error (cadr result))))
+
+(define (test-junit-report result)
+  `(testcase
+	(@ (name ,(symbol->string (car result))))
+	,@(cond
+	   ((fail? result) `((failure (@ (message ,(cddr result))))))
+	   ((error? result) `((error (@ (message ,(cddr result))))))
+	   (#t '()))))
+
+(define (junit-report results fails errors)
+  (let ((count (length results)))
+	`(testsuites
+	  (testsuite
+	   (@ (name "wipforth e2e")
+		  (tests ,count)
+		  (failures ,fails)
+		  (errors ,errors))
+	   ,@(map test-junit-report results)))))
+
+(define (run-tests)
+  (let* ((results (map run-test (fluid-ref *tests*)))
+		 (fails (length (filter fail? results)))
+		 (errors (length (filter error? results))))
+	(sxml->xml (junit-report results fails errors))
+	(exit (if (= (+ fails errors) 0) 0 1))))
+
+(define-syntax-rule (run-tests-with-cleanup body ...)
+  (dynamic-wind
+	(lambda () #f)
+	run-tests
+	(lambda () body ...)))

emu.js

@@ -11,6 +11,7 @@ const RXBUF_SIZE = 32;
 const PERIPHS_SIZE = 81;
 
 const POLL_INTERVAL_MS = 20;
+const DOT_INTERVAL_MS = 120;
 
 const COLS = 80;
 const TAB_WIDTH = 8;
@@ -50,8 +51,29 @@ class Emulator {
 		document.addEventListener('keydown', (e) => this.handle_keydown(e));
 		window.addEventListener('resize', () => this.handle_resize());
 
-		this.worker = new Worker('boot.js');
-		this.worker.postMessage(this.mem);
+		this.prof = new Worker("prof.js");
+		this.prof.onmessage = (e) => {
+			const blob = new Blob(
+				[JSON.stringify(e.data)],
+				{ type: "application/json" });
+			const url = URL.createObjectURL(blob);
+			const a = document.createElement("a");
+			a.href = url;
+			a.download = "wipforth-profile.json";
+			a.click();
+			URL.revokeObjectURL(url);
+		};
+
+		this.print("Assembling kernel ");
+		const dots = setInterval(() => this.print("."), DOT_INTERVAL_MS);
+		this.worker = new Worker('boot.js', { type: 'module' });
+		this.worker.postMessage({ type: "load", mem: this.mem });
+		this.worker.onmessage = (e) => {
+			clearInterval(dots);
+			this.print(" done\n");
+			this.worker.postMessage({ type: "boot" });
+			this.prof.postMessage({ type: "start", mem: this.mem });
+		};
 
 		fetch('prelude.f')
 			.then(res => res.text())
@@ -77,6 +99,7 @@ class Emulator {
 		if (!this.input_enable) {
 			const sysready = Atomics.load(this.mem_u8, SYSREADY);
 			if (sysready != 0) {
+				this.prof.postMessage({ type: "stop" });
 				this.input_enable = true;
 				this.flush_output();
 				document.getElementById('cursor').classList.add('blinking');

prelude.f

@@ -249,8 +249,8 @@ CHAR . EMIT
 \ Version number
 
 0 CONSTANT VERSION-MAJOR
-1 CONSTANT VERSION-MINOR
-0 CONSTANT VERSION-PATCH
+2 CONSTANT VERSION-MINOR
+1 CONSTANT VERSION-PATCH
 
 : PRINT-VERSION
   CHAR v EMIT VERSION-MAJOR .

prof.js

@@ -0,0 +1,48 @@
+const INTERVAL_MS = 1;
+const RS_TOP_ADDR = 0x10000;
+const PROF_DATA_ADDR = 0x58;
+const PROF_DATA_IDX = PROF_DATA_ADDR / 8;
+
+let mem_8;
+let mem_64;
+let sampler;
+
+const samples = [];
+
+function sample() {
+	const data = Atomics.load(mem_64, PROF_DATA_IDX);
+	const ip = Number(data & 0xffffffffn);
+	const rsp = Number(data >> 32n);
+	samples.push({ ip, rs_bytes: mem_8.slice(rsp, RS_TOP_ADDR) });
+}
+
+function i32(bytes) {
+	return bytes[0]
+		| (bytes[1] << 8)
+		| (bytes[2] << 16)
+		| (bytes[3] << 24);
+}
+function postproc({ ip, rs_bytes }) {
+	const rs = [];
+	for (let i = 0; i < rs_bytes.length; i += 4)
+		rs.push(i32(rs_bytes.slice(i, i + 4)));
+	rs.reverse();
+	return { ip, rs };
+}
+
+self.onmessage = (e) => {
+	switch (e.data.type) {
+	case "start":
+		console.log("Starting profiler");
+		mem_8 = new Uint8Array(e.data.mem.buffer);
+		mem_64 = new BigUint64Array(e.data.mem.buffer);
+		ip = e.data.ip;
+		rsp = e.data.rsp;
+		sampler = setInterval(sample, INTERVAL_MS);
+		break;
+	case "stop":
+		clearInterval(sample);
+		console.log("Stopped profiler");
+		self.postMessage(samples.map(postproc));
+	}
+};

server.scm

@@ -1,5 +1,12 @@
+(define-module (server)
+  #:export (run start stop main))
+
 (use-modules
+ (ice-9 atomic)
  (ice-9 binary-ports)
+ (ice-9 threads)
+ (srfi srfi-9)
+ (web client)
  (web server)
  (web request)
  (web response)
@@ -9,9 +16,8 @@
   '(("html" . (text/html))
 	("css"  . (text/css))
 	("js"   . (application/javascript))
-	("wasm" . (application/wasm))
 	("f"    . (text/plain))
-	("wat"  . (text/plain))
+	("ws"   . (text/plain))
 	("png"  . (image/png))))
 
 (define (mime-type path)
@@ -38,6 +44,38 @@
 	(if path
 		(values (cons `(content-type . ,(mime-type path)) headers)
 				(get-bytevector-all (open-input-file path)))
-		(values (build-response #:code 404) ""))))
+		(values (build-response #:code 404) #f))))
 
-(run-server file-handler)
+(define* (run #:key (port 8080))
+  (run-server file-handler 'http `(#:port ,port)))
+
+(define-record-type <handle>
+  (make-handle close-flag thread port)
+  handle?
+  (close-flag handle-close-flag)
+  (thread handle-thread)
+  (port handle-port))
+
+(define (serve impl server should-close)
+  (let loop ()
+	(unless (atomic-box-ref should-close)
+	  (serve-one-client file-handler impl server '())
+	  (loop)))
+  (close-server impl server))
+
+(define* (start #:key (port 8080))
+  (let* ((impl (lookup-server-impl 'http))
+		 (server (open-server impl `(#:port ,port)))
+		 (should-close (make-atomic-box #f))
+		 (thread
+		  (call-with-new-thread
+		   (lambda () (serve impl server should-close)))))
+	(make-handle should-close thread port)))
+
+(define (stop handle)
+  (atomic-box-set! (handle-close-flag handle) #t)
+  (http-request (format #f "http://localhost:~a/" (handle-port handle)))
+  (join-thread (handle-thread handle)))
+
+(when (string=? (basename (current-filename)) (car (command-line)))
+  (run))

tests.scm

@@ -0,0 +1,52 @@
+(add-to-load-path (dirname (current-filename)))
+
+(use-modules
+ (e2e marionette)
+ (e2e testing)
+ (ice-9 regex)
+ ((server) #:prefix server-)
+ (srfi srfi-1))
+
+(define (lines s)
+  (string-split s #\newline))
+
+(define (get-result-line client)
+  (let ((display (get-display client)))
+	(last (lines (string-trim-right display)))))
+
+(define server (server-start))
+(define firefox (start-firefox))
+(define client (client-setup))
+
+(navigate client "http://localhost:8080")
+(sleep 5)
+
+(define-test kernel-assembles-successfully
+  (let* ((display (get-display client))
+		 (line (first (lines display))))
+	(assert (string-match "Assembling kernel \\.+ done" line)
+			(format #f "Kernel assemble line: ~s" line))))
+
+(define-test prelude-loads-successfully
+  (let* ((display (get-display client))
+		 (line (second (lines display))))
+	(assert (string-match "Loading prelude \\.+ done" line)
+			(format #f "Prelude load line: ~s" line))))
+
+(define-test six-seven-times-dot-cr-yields-42
+  (input-line client "6 7 * . CR")
+  (let* ((result-line (get-result-line client)))
+	(assert (string=? "42" result-line)
+			(format #f "Result line: ~s" result-line))))
+
+(define-test define-hello-then-run-hello-prints-message
+  (input-line client ": HELLO .\" Hello, world!\" CR ;")
+  (input-line client "HELLO")
+  (let* ((result-line (get-result-line client)))
+	(assert (string=? "Hello, world!" result-line)
+			(format #f "Result line: ~s" result-line))))
+
+(run-tests-with-cleanup
+ (client-teardown client)
+ (close-firefox firefox)
+ (server-stop server))

words.js

@@ -0,0 +1,16 @@
+import { Assembler } from "./asm.js";
+
+const asm = new Assembler();
+for await (const chunk of Deno.stdin.readable) {
+	asm.push(chunk);
+}
+asm.wasm();
+
+const defs = Object.entries(asm.defs);
+while (defs[0][0] != '_DUP')
+	defs.shift();
+while (defs.at(-1)[0] != 'WNF_HANDLER')
+	defs.pop();
+const words = Object.fromEntries(defs.filter(([k,v]) => !k.startsWith("_")));
+
+console.log(JSON.stringify(words));