diff --git a/_web_server/index.html b/_web_server/index.html new file mode 100644 index 0000000..70a66ef --- /dev/null +++ b/_web_server/index.html @@ -0,0 +1,93 @@ + + + + Verilog Playground + + + + +
+
+ +
+
`timescale 10ps/10ps + +module test; + initial begin + $display("Hello world!"); + $finish(); + end +endmodule +
+
+ +
+
+ + + + + + diff --git a/_web_server/playground-server.scm b/_web_server/playground-server.scm new file mode 100755 index 0000000..15626bc --- /dev/null +++ b/_web_server/playground-server.scm @@ -0,0 +1,296 @@ +#!/usr/bin/env -S guile -e "main" -s +!# + +;; -*- geiser-scheme-implementation: guile -*- + +(import (srfi srfi-1) + (srfi srfi-11) + (srfi srfi-28) + (rnrs bytevectors) + (web server) + (web request) + (web response) + (web uri) + (sxml simple) + (ice-9 regex) + (ice-9 binary-ports) + (ice-9 textual-ports) + (ice-9 popen)) + +(import (embddr common) + (embddr optargs)) + +(define MAIN-PAGE "index.html") +(define LOGGING #f) + +(define (multistring . strings) + (apply string-append + (insert-between strings "\n"))) + +(define (not-found request) + (values (build-response #:code 404) + (string-append "Resource not found: " + (uri->string (request-uri request))))) + +(define* (make-response str #:key (type 'text/html)) + (values (build-response + #:headers `((content-type . (,type (charset . "utf-8")))) + #:code 200) + str)) + +(define* (file-reader file-name #:key (max-read-length 512)) + (lambda (port) + (with-input-from-file file-name + (lambda () + (let loop () + (let ((data (get-bytevector-n (current-input-port) + max-read-length))) + (when (not (eof-object? data)) + (put-bytevector port data) + (loop)))))))) + +(define* (file-response file #:key (type 'text/html)) + (make-response (file-reader file) #:type type)) + +(define-syntax guard + (syntax-rules () + ((_ default code...) + (with-exception-handler (lambda (e) default) + (lambda () code...) + #:unwind? #t)))) + +(define (printlog . rest) + (when LOGGING + (display (apply format rest)))) + +;;; +;;; Return directory list +;;; +(define (list-dir path) + (if (file-exists? path) + (let ((dir (opendir path))) + (let loop ((ls '())) + (let ((item (readdir dir))) + (if (eof-object? item) + (begin + (closedir dir) + ls) + (if (or (string=? item ".") + (string=? item "..")) + (loop ls) + (loop (cons (string-append path "/" item) ls))))))) + '())) + +;;; +;;; Recursive delete directory +;;; +(define (delete-recursive path) + (let ((path (canonicalize-path path))) + (if (eq? 'directory (stat:type (stat path))) + (begin + (for-each delete-recursive (list-dir path)) + (rmdir path)) + (delete-file path)))) + +;;; +;;; Trim list +;;; +(define (list-trim l pred) + (cond + ((null? l) '()) + ((pred (car l)) (list-trim (cdr l) pred)) + (else + (let ((lr (reverse l))) + (if (pred (car lr)) + (reverse (list-trim (cdr lr) pred)) + l))))) + +;;; +;;; Execute system command and capture stdout and stderr to string list +;;; +(define* (system-to-string cmd #:key (pwd #f)) + (let* ((cmd (string-append cmd " 2>&1")) + (cmd (if pwd (format "cd ~a; ~a" pwd cmd) cmd)) + (p (open-input-pipe cmd)) + (out (get-string-all p))) + (values (close-pipe p) out))) + +(define* (system-to-string-list cmd #:key (pwd #f)) + (let-values (((status out) + (system-to-string cmd #:pwd pwd))) + (values + status + (list-trim (string-split out #\newline) string-null?)))) + +(define (iverilog-cmd base) + (format "iverilog -DTESTBENCH -g2012 -o ~a/testbench.vvp ~a/testbench.sv" base base)) + +(define (vvp-cmd base) + (format "vvp ~a/testbench.vvp" base)) + +;;; +;;; Trivial sanitize verilog code +;;; +(define (sanitize-verilog code) + (let* (;; $f* functions but not $finish + (code (regexp-substitute/global #f "\\$f[a-hj-z][a-z]+" code 'pre "$error" 'post)) + ;; $scanf + (code (regexp-substitute/global #f "\\$.?scanf" code 'pre "$error" 'post)) + ;; $readmem + (code (regexp-substitute/global #f "\\$readmem[bh]" code 'pre "$error" 'post)) + ;; $dump* + (code (regexp-substitute/global #f "\\$dump[a-z]*" code 'pre "$error" 'post))) + code)) + +;;; +;;; Get module name +;;; +(define (module-name code) + (let ((rx (make-regexp + "(^|\\s)module\\s*(\\s|(#\\(.*\\)\\s*))[a-zA-Z0-9_]+"))) + (let loop ((pos 0) + (modname #f)) + (let ((m (regexp-exec rx code pos))) + (if m + (loop (match:end m) (match:substring m)) + (if modname + (match:substring (string-match "[a-zA-Z0-9_]+$" modname)) + #f)))))) + +;;; +;;; Create file with simulation timeout watchdog +;;; +(define (create-timeout-module path modname timeout) + (define (* . fmt) (display (apply format fmt)) (newline)) + (let ((filename (format "~a/~a.v" path modname))) + (with-output-to-file filename + (lambda () + (* "`timescale 1ps/1ps") + (* "module ~a();" modname) + (* " initial begin") + (if (list? timeout) + (* " #(~a~a);" + (car timeout) + (if (null? (cdr timeout)) + "" + (symbol->string (cadr timeout)))) + (* " #~a;" timeout)) + (* " $display(\"Timeout at %0t\", $time);") + (* " $finish;") + (* " end") + (* "endmodule"))) + filename)) + +;;; +;;; Create dump module +;;; +(define (create-dump-module path modname top) + (define (* . fmt) (display (apply format fmt)) (newline)) + (let ((filename (format "~a/~a.v" path modname))) + (with-output-to-file filename + (lambda () + (* "`timescale 1ps/1ps") + (* "module ~a();" modname) + (* " initial begin") + (* " $dumpfile(\"~a/~a.vcd\");" path modname) + (* " $dumpvars(0, ~a);" top) + (* " end") + (* "endmodule"))) + filename)) + +;;; +;;; Execute testbench +;;; +(define (execute-icarus code) + (let ((top-module (module-name code))) + (if (not top-module) + "No modules declared\n" + (let* ((work-dir (mkdtemp (format "work-~a-XXXXXX" (current-time)))) + (verilog-file (format "~a/testbench.sv" work-dir)) + (timeout-file (create-timeout-module work-dir "timeout" '(1 us))) + (dump-file (create-dump-module work-dir "dump" top-module))) + (with-output-to-file verilog-file + (lambda () (display code))) + + ;; Compile + (let ((log + (let ((cmdline + (format "iverilog -DTESTBENCH -g2012 -o ~a/testbench.vvp ~a ~a ~a" + work-dir verilog-file timeout-file dump-file))) + (let-values (((status out) + (system-to-string cmdline))) + (let ((compile-log + (string-append + (format "$ ~a\n" cmdline) + (format "Return code: ~a\n" status) + (if (string-null? out) + "\n" + (format "--\n~a\n" out))))) + (if (not (zero? status)) + compile-log + + ;; Execute + (let ((cmdline (format "vvp ~a/testbench.vvp" work-dir))) + (let-values (((status out) + (system-to-string cmdline))) + (let ((execution-log + (string-append + (format "$ ~a\n" cmdline) + (format "Return code: ~a\n" status) + (if (string-null? out) + "\n" + (format "--\n~a\n" out))))) + (string-append compile-log execution-log)))))))))) + + (delete-recursive work-dir) + log))))) + +;;; +;;; Web page handler +;;; +(define (page-handler request request-body) + (let ((path (split-and-decode-uri-path + (uri-path + (request-uri request))))) + (printlog "-- PATH: ~a\n" path) + + (cond + ;; Editor javascript files + ;; ((and (> (length path) 2) + ;; (equal? (take path 2) '("ace-builds" "src-min-noconflict")) + ;; (string-match "^[a-z_-]+\\.js$" (third path))) + ;; (guard (not-found request) + ;; (let* ((file-path (canonicalize-path + ;; (apply + ;; string-append + ;; (insert-between (cons "." path) + ;; file-name-separator-string)))) + ;; (file-stat (stat file-path))) + ;; (if (and (eq? (stat:type file-stat) 'regular) + ;; (not (zero? (logand (stat:mode file-stat) #o444)))) + ;; (begin + ;; (printlog "-- Request file '~a'\n" file-path) + ;; (file-response file-path #:type 'text/javascript)) + ;; (not-found request))))) + + ;; Icarus + ((equal? path '("icarus")) + (printlog "-- Request icarus\n") + (let ((log (execute-icarus + (sanitize-verilog + (utf8->string request-body))))) + (make-response log #:type 'text/plain))) + + ;; Index page + ((null? path) + (printlog "-- Request index page\n") + (make-response MAIN-PAGE)) + + ;; Unknown + (else + (printlog "-- Request wrong path\n") + (not-found request))))) + +(define (main args) + (set! MAIN-PAGE (call-with-input-file MAIN-PAGE get-string-all)) + (run-server page-handler))