1102 lines
39 KiB
Scheme
Executable File
1102 lines
39 KiB
Scheme
Executable File
#!/usr/bin/env -S guile -e "main" -s
|
|
!#
|
|
|
|
;; -*- geiser-scheme-implementation: guile -*-
|
|
|
|
(import (srfi srfi-1)
|
|
(srfi srfi-11)
|
|
(srfi srfi-26)
|
|
(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)
|
|
(embddr vcd))
|
|
|
|
(define INDEX-FILE "index.html")
|
|
(define DELETE-WORK-DIR #t)
|
|
|
|
(define TOP-MODULE "testbench")
|
|
(define SNIPPET-FILE "code.sv")
|
|
(define IVERILOG-METATOP-FILE "top_iverilog.sv")
|
|
(define VERILATOR-CPP-FILE "top_verilator.cpp")
|
|
(define USE-TIME-IN-SAVE-URL #f)
|
|
|
|
(define IVERILOG-EXE "iverilog")
|
|
(define VVP-EXE "vvp")
|
|
(define VERILATOR-EXE "verilator")
|
|
|
|
(define URI-IVERILOG "iverilog")
|
|
(define URI-VERILATOR "verilator")
|
|
(define URI-SAVE-CODE "save")
|
|
|
|
(define LOG-DBG 3)
|
|
(define LOG-VERBOSE 2)
|
|
(define LOG-INFO 1)
|
|
(define LOG-ERROR 0)
|
|
|
|
(define LOG-LEVEL LOG-VERBOSE)
|
|
|
|
(define DEFAULT-CODE
|
|
(string-append
|
|
"`timescale 1ps/1ps\n\n"
|
|
;; (format "module ~a (input clock);\n" TOP-MODULE)
|
|
(format "module ~a;\n" TOP-MODULE)
|
|
" logic clock = 1'b0;\n"
|
|
" initial forever #(5ns) clock = ~clock;\n"
|
|
"\n"
|
|
" initial begin\n"
|
|
" $display(\"Hello world!\");\n"
|
|
" repeat(10) @(posedge clock);\n"
|
|
" $finish();\n"
|
|
" end\n"
|
|
"endmodule\n"))
|
|
|
|
(define DEFAULT-CANVAS-WIDTH 800)
|
|
|
|
(define (multistring . strings)
|
|
(apply string-append
|
|
(insert-between strings "\n")))
|
|
|
|
(define-syntax guard
|
|
(syntax-rules ()
|
|
((_ default code...)
|
|
(with-exception-handler (lambda (e) default)
|
|
(lambda () code...)
|
|
#:unwind? #t))))
|
|
|
|
(define (print . args)
|
|
(display (apply format args)))
|
|
|
|
(define (println . args)
|
|
(display (apply format args))
|
|
(newline))
|
|
|
|
;;;
|
|
;;; Logger
|
|
;;;
|
|
(define (logger . args)
|
|
(unless (null? args)
|
|
(let ((prefix
|
|
(format "~a | "
|
|
(strftime "%c" (localtime (current-time))))))
|
|
(if (number? (car args))
|
|
(when (<= (car args) LOG-LEVEL)
|
|
(display prefix)
|
|
(display (apply format (cdr args)))
|
|
(newline))
|
|
(begin
|
|
(display prefix)
|
|
(display (apply format args))
|
|
(newline))))
|
|
(force-output (current-output-port))))
|
|
|
|
;;;
|
|
;;; 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)))))
|
|
|
|
;;;
|
|
;;; Read template to string
|
|
;;;
|
|
(define (read-template-text file subst)
|
|
(let ((lines (read-template file "%~a%" subst)))
|
|
(apply string-append
|
|
(append-map (cut list <> "\n") lines))))
|
|
|
|
;;;
|
|
;;; 404 response
|
|
;;;
|
|
(define (not-found request)
|
|
(values (build-response #:code 404)
|
|
(string-append "Resource not found: "
|
|
(uri->string (request-uri request)))))
|
|
|
|
;;;
|
|
;;; Common text/html response
|
|
;;;
|
|
(define* (make-response str #:key
|
|
(content-type 'text/html)
|
|
(content-type-params '((charset . "utf-8"))))
|
|
(values (build-response
|
|
#:headers `((content-type . (,content-type ,@content-type-params)))
|
|
;; #:headers `((content-type . (,(if (null? encoding)
|
|
;; type
|
|
;; (cons type encoding)))))
|
|
#:code 200)
|
|
str))
|
|
|
|
;;;
|
|
;;; File reader
|
|
;;;
|
|
(define* (file-reader file-name #:key
|
|
(max-read-length 512)
|
|
(max-file-size #f))
|
|
(lambda (port)
|
|
(guard ""
|
|
(call-with-input-file file-name
|
|
(lambda (in)
|
|
(let loop ((readed 0))
|
|
(when (or (not max-file-size)
|
|
(< readed max-file-size))
|
|
(let ((data (get-bytevector-n in max-read-length)))
|
|
(unless (eof-object? data)
|
|
(put-bytevector port data)
|
|
(loop (+ readed (bytevector-length data))))))))
|
|
#:binary #t))))
|
|
|
|
;;;
|
|
;;; File response
|
|
;;;
|
|
(define* (file-response file #:key
|
|
(content-type 'application/octet-stream)
|
|
(content-type-params '((charset . "")))
|
|
(max-file-size #f))
|
|
(make-response
|
|
(file-reader file #:max-file-size max-file-size)
|
|
#:content-type content-type
|
|
#:content-type-params content-type-params))
|
|
|
|
;;;
|
|
;;; Simple format with convert input number to inexact numbers
|
|
;;;
|
|
(define (format-inex . args)
|
|
(apply format
|
|
(map (lambda (arg)
|
|
(if (number? arg)
|
|
(exact->inexact
|
|
(/ (round (* arg 100)) 100))
|
|
arg))
|
|
args)))
|
|
|
|
;;;
|
|
;;; Make SVG drawing of VCD signals
|
|
;;;
|
|
(define* (vcd-signal->svg signal tstart tend x y width height text-position
|
|
#:key (id #f) (data-hw 3))
|
|
(let* ((time-per-pixel (/ (- tend tstart) width))
|
|
(sig-width (vcd-signal-size signal))
|
|
(sig-type (vcd-signal-type signal))
|
|
(y0 y)
|
|
(y1 (+ y height))
|
|
(yz (+ y (/ height 2)))
|
|
(half-dy (/ (- y1 y0) 2))
|
|
(id (if id (format " id=\"~a\"" id) "")))
|
|
|
|
(let next-sample ((samples (vcd-signal-get signal))
|
|
(value (if (eq? sig-type 'real)
|
|
0
|
|
(make-string sig-width #\x)))
|
|
(time tstart)
|
|
(svg '()))
|
|
|
|
(if (null? samples)
|
|
svg
|
|
(let ((sample-time (car (car samples)))
|
|
(sample-value (cdr (car samples))))
|
|
(if (and (< sample-time tend)
|
|
(or (< (- sample-time time) time-per-pixel)
|
|
(and (equal? value sample-value)
|
|
(not (eq? sig-type 'event)))))
|
|
(next-sample
|
|
(cdr samples)
|
|
(if (<= sample-time tstart)
|
|
sample-value
|
|
value)
|
|
time svg)
|
|
(next-sample
|
|
(cdr samples) sample-value sample-time
|
|
(cons
|
|
(cond
|
|
((or (eq? sig-type 'bits)
|
|
(eq? sig-type 'real))
|
|
|
|
(if (and (= sig-width 1)
|
|
(not (eq? sig-type 'real))
|
|
(not (char-ci=? (string-ref value 0) #\x)))
|
|
;; Scalar
|
|
(let ((x0 (+ x (/ (- time tstart) time-per-pixel)))
|
|
(x1 (+ x (/ (- sample-time tstart) time-per-pixel))))
|
|
(string-append
|
|
(format-inex "<path~a d=\"M~a ~a v~a\"/>" id x0 y0 (- y1 y0))
|
|
(format-inex "<path~a d=\"M~a ~a h~a\"/>"
|
|
id x0
|
|
(cond
|
|
((equal? value "0") y1)
|
|
((equal? value "1") y0)
|
|
(else yz))
|
|
(- x1 x0))))
|
|
|
|
;; Vector or Real
|
|
(let ((x0 (+ x (/ (- time tstart) time-per-pixel)))
|
|
(x1 (+ x (/ (- sample-time tstart) time-per-pixel))))
|
|
(string-append
|
|
;; Horizontal lines
|
|
(let ((x0 (+ x0 (if (<= time tstart) 0 data-hw)))
|
|
(x1 (- x1 (if (>= sample-time tend) 0 data-hw))))
|
|
(format-inex
|
|
"<path~a d=\"M~a ~a L~a ~a M~a ~a L~a ~a\"/>"
|
|
id x0 y0 x1 y0 x0 y1 x1 y1))
|
|
|
|
;; Left cross
|
|
(if (<= time tstart)
|
|
""
|
|
(format-inex "<path~a d=\"M~a ~a l~a ~a\"/><path d=\"M~a ~a l~a ~a\"/>"
|
|
id
|
|
x0 yz data-hw (- half-dy)
|
|
x0 yz data-hw (+ half-dy)))
|
|
|
|
;; Right cross
|
|
(if (>= sample-time tend)
|
|
""
|
|
(format-inex "<path~a d=\"M~a ~a l~a ~a\"/><path d=\"M~a ~a l~a ~a\"/>"
|
|
id
|
|
x1 yz (- data-hw) (- half-dy)
|
|
x1 yz (- data-hw) (+ half-dy)))
|
|
|
|
;; Text
|
|
(format-inex "<svg~a x=\"~a\" y=\"~a\" width=\"~a\" height=\"~a\">"
|
|
id
|
|
(+ x0 data-hw)
|
|
y0
|
|
(- x1 x0 (* data-hw 2))
|
|
(- y1 y0))
|
|
(format-inex "<text x=\"~a\" y=\"~a\">" 0 text-position)
|
|
(string-upcase
|
|
(if (or (eq? sig-type 'real)
|
|
(<= sig-width 4))
|
|
value
|
|
(vcd-binary->hex value #t)))
|
|
"</text></svg>"))))
|
|
|
|
;; Event TODO
|
|
((eq? sig-type 'event)
|
|
""))
|
|
svg))))))))
|
|
|
|
;;;
|
|
;;; Make legend SVG text for VCD
|
|
;;;
|
|
(define* (vcd-signals->legend signals text-spacing text-position)
|
|
(if (null? signals)
|
|
""
|
|
(let ((common-scope-len
|
|
(length
|
|
(fold
|
|
(lambda (scope common)
|
|
(let loop ((scope scope)
|
|
(common common)
|
|
(out '()))
|
|
(if (or (null? scope)
|
|
(null? common))
|
|
(reverse out)
|
|
(if (string-ci= (car scope)
|
|
(car common))
|
|
(loop (cdr scope)
|
|
(cdr common)
|
|
(cons (car scope) out))
|
|
(reverse out)))))
|
|
(vcd-signal-scope (car signals))
|
|
(map vcd-signal-scope (cdr signals))))))
|
|
(map
|
|
(lambda (sig n)
|
|
(string-append
|
|
(format-inex "<text x=\"0\" y=\"~a\">~a</text>"
|
|
(+ (* n text-spacing) text-position)
|
|
(string-concatenate
|
|
(insert-between
|
|
(append
|
|
(drop (vcd-signal-scope sig)
|
|
common-scope-len)
|
|
`(,(vcd-signal-name sig)))
|
|
".")))))
|
|
signals
|
|
(iota (length signals))))))
|
|
|
|
;;;
|
|
;;; Create SVG from VCD
|
|
;;;
|
|
(define* (vcd->svg vcd width #:key
|
|
(signal-height 15)
|
|
(signal-text-position 12)
|
|
(margin 5)
|
|
(signal-spacing 5)
|
|
(legend-width 150)
|
|
(extra-delim-y 3))
|
|
|
|
(let ((tstart (apply min (vcd-timestamps vcd)))
|
|
(tend (apply max (vcd-timestamps vcd)))
|
|
(signals (sort
|
|
(vcd-signals vcd)
|
|
(lambda (a b)
|
|
(and (not (equal? (vcd-signal-name b) "clock"))
|
|
(or
|
|
(and (equal? (vcd-signal-name a) "clock")
|
|
(not (equal? (vcd-signal-name b) "clock")))
|
|
|
|
(< (length (vcd-signal-scope a))
|
|
(length (vcd-signal-scope b)))
|
|
|
|
(string-ci<? (vcd-signal-name a)
|
|
(vcd-signal-name b))))))))
|
|
|
|
(if (<= tend tstart)
|
|
'()
|
|
(let ((signals-x (+ (* 2 margin) legend-width))
|
|
(signals-w (- width legend-width (* 3 margin)))
|
|
(height
|
|
(+ (* 2 margin)
|
|
(* signal-height (length signals))
|
|
(* signal-spacing (- (length signals) 1)))))
|
|
|
|
(append
|
|
;; Header
|
|
`(,(format-inex "<svg id=\"wave\" width=\"~a\" height=\"~a\"" width height)
|
|
,(format "preserveAspectRatio=\"xMidYMin slice\" role=\"img\">")
|
|
,(format "<g id=\"wave-background\"><rect width=\"100%\" height=\"100%\"/></g>"))
|
|
|
|
;; Legend
|
|
`(,(format-inex "<svg id=\"wave-legend\" x=\"~a\" y=\"~a\" width=\"~a\" height=\"~a\">"
|
|
margin margin legend-width (- height (* 2 margin))))
|
|
(vcd-signals->legend signals
|
|
(+ signal-height signal-spacing)
|
|
signal-text-position)
|
|
'("</svg>")
|
|
|
|
;; Clock
|
|
`(,(format "<g id=\"wave-clock\">"))
|
|
(vcd-signal->svg (car signals) tstart tend
|
|
signals-x margin
|
|
signals-w signal-height signal-text-position)
|
|
'("</g>")
|
|
|
|
;; Rest
|
|
`(,(format "<g id=\"wave-signals\">"))
|
|
(fold
|
|
(lambda (sig n out)
|
|
(append
|
|
out
|
|
(vcd-signal->svg sig tstart tend
|
|
signals-x
|
|
(+ margin
|
|
(* n signal-height)
|
|
(* n signal-spacing))
|
|
signals-w signal-height signal-text-position)))
|
|
'()
|
|
(cdr signals)
|
|
(iota (length
|
|
(cdr signals))
|
|
1))
|
|
'("</g>")
|
|
|
|
;; Delimiter
|
|
`(,(format-inex "<g id=\"wave-delim\"><path d=\"M~a ~a v~a\"/></g>"
|
|
(+ legend-width (* 2 margin)) (- margin extra-delim-y)
|
|
(- height (* 2 (- margin extra-delim-y)))))
|
|
|
|
;; Close svg tag
|
|
'("</svg>"))))))
|
|
|
|
;;;
|
|
;;; Execute system command and capture stdout and stderr to string
|
|
;;;
|
|
(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)))
|
|
|
|
;;;
|
|
;;; Same as system-to-string but returns execution time (in ms) also
|
|
;;;
|
|
(define* (system-to-string-with-time cmd #:key (pwd #f))
|
|
(let ((start-time (gettimeofday)))
|
|
(let-values
|
|
(((status out)
|
|
(system-to-string cmd #:pwd pwd)))
|
|
(let ((stop-time (gettimeofday)))
|
|
(values status out
|
|
(exact->inexact
|
|
(- (+ (* (car stop-time) 1000)
|
|
(/ (cdr stop-time) 1000))
|
|
(+ (* (car start-time) 1000)
|
|
(/ (cdr start-time) 1000)))))))))
|
|
|
|
;;;
|
|
;;; Execute system command and capture stdout and stderr to string list
|
|
;;;
|
|
(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?))))
|
|
|
|
;;;
|
|
;;; Make pretty log from executable output
|
|
;;;
|
|
(define (exe-log-pretty cmdline status out time)
|
|
(string-append
|
|
(format "$ ~a\n" cmdline)
|
|
(format "Return code: ~a, Exec time: ~a ms\n" status time)
|
|
(if (string-null? out)
|
|
"\n"
|
|
(format "--\n~a\n" out))))
|
|
|
|
;;;
|
|
;;; 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))
|
|
|
|
;;;
|
|
;;; Concatenate path elements and remove duplicate slashes
|
|
;;;
|
|
(define (path+ . paths)
|
|
(reverse-list->string
|
|
(string-fold
|
|
(lambda (c s)
|
|
(if (and (not (null? s))
|
|
(char=? c #\/)
|
|
(char=? (car s) #\/))
|
|
s (cons c s)))
|
|
'() (string-concatenate
|
|
(insert-between
|
|
(remove string-null?
|
|
(map string-trim-both paths))
|
|
"/")))))
|
|
|
|
(define (wrap-exe exe wrapper)
|
|
(format "~a~a" (if wrapper (format "~a " wrapper) "") exe))
|
|
|
|
;;;
|
|
;;; Make workdir with sources and command file. Common part
|
|
;;; Returns work directory path string, verilog file name
|
|
;;; and command file name.
|
|
;;;
|
|
(define* (make-sim-workdir code base top)
|
|
(let* ((work-dir (mkdtemp (path+ base (format "work-~a-XXXXXX" (current-time)))))
|
|
(verilog-file (path+ work-dir (format "~a.sv" top)))
|
|
(command-file (path+ work-dir (format "~a.vc" top))))
|
|
(with-output-to-file verilog-file (cut display code))
|
|
(values work-dir verilog-file command-file)))
|
|
|
|
;;;
|
|
;;; Create workdir for Icarus Verilog
|
|
;;; Returns directory path
|
|
;;;
|
|
(define* (make-iverilog-workdir code metatop base top)
|
|
(let-values (((work-dir verilog-file command-file)
|
|
(make-sim-workdir code base top)))
|
|
(let ((metatop-file (path+ work-dir (format "__~a__.sv" top))))
|
|
(with-output-to-file metatop-file
|
|
(cut display (substitute metatop "@~a@"
|
|
`((WORKDIR ,work-dir)
|
|
(TOPMODULE ,top)))))
|
|
|
|
(with-output-to-file command-file
|
|
(lambda ()
|
|
(println "~a" metatop-file)
|
|
(println "~a" verilog-file)
|
|
(println "+define+TESTBENCH")
|
|
(println "+timescale+1ps/1ps"))))
|
|
work-dir))
|
|
|
|
;;;
|
|
;;; Create workdir for Verilator
|
|
;;; Returns directory path
|
|
;;;
|
|
(define* (make-verilator-workdir code cpp jobs base top)
|
|
(let-values (((work-dir verilog-file command-file)
|
|
(make-sim-workdir code base top)))
|
|
(let ((cpp-file (path+ work-dir (format "~a.cpp" top))))
|
|
(with-output-to-file cpp-file
|
|
(cut display (substitute cpp "@~a@" `((WORKDIR ,work-dir)
|
|
(TOPMODULE ,top)))))
|
|
|
|
(with-output-to-file command-file
|
|
(lambda ()
|
|
(println "-DTESTBENCH")
|
|
(println "--timescale 1ps/1ps")
|
|
(println "--top-module ~a" top)
|
|
(println "--Mdir ~a" (path+ work-dir top))
|
|
(println "-cc")
|
|
(println "-O2")
|
|
(when (> jobs 0)
|
|
(println "--build-jobs ~a" jobs))
|
|
(println "-o ~a" top)
|
|
(println "--exe")
|
|
(println "--build")
|
|
(println "-sv")
|
|
(println "-Wno-WIDTH")
|
|
(println "+1800-2023ext+sv")
|
|
(println "--timing")
|
|
(println "--trace")
|
|
(println "--trace-structs")
|
|
(println "--trace-depth 1")
|
|
(println "--quiet-exit")
|
|
(println "~a" verilog-file)
|
|
(println "~a.cpp" top))))
|
|
work-dir))
|
|
|
|
;;;
|
|
;;; Execute secuence of commands and return (values status "execution log")
|
|
;;; Break execution on error
|
|
;;;
|
|
(define (exec-sequence cmds)
|
|
(let-values
|
|
(((status logs)
|
|
(let next-cmd ((cmds cmds)
|
|
(logs '()))
|
|
(if (null? cmds)
|
|
(values 0 logs)
|
|
(let ((cmd (car cmds)))
|
|
(let-values (((status out time)
|
|
(system-to-string-with-time cmd)))
|
|
(let ((logs (cons (exe-log-pretty cmd status out time) logs)))
|
|
(if (zero? status)
|
|
(next-cmd (cdr cmds) logs)
|
|
(values status logs)))))))))
|
|
(values status (string-concatenate (reverse logs)))))
|
|
|
|
;;;
|
|
;;; Read and parse VCD file
|
|
;;;
|
|
(define* (vcd-file-read file #:optional (signal-need? (lambda (s) #t)))
|
|
(if (file-exists? file)
|
|
(guard #f
|
|
(call-with-input-file file
|
|
(cut vcd-parse <> signal-need?)))
|
|
#f))
|
|
|
|
;;;
|
|
;;; Compile sources and execute simulation with Icarus Verilog
|
|
;;; Returns (values status log vcd)
|
|
;;;
|
|
(define (exec-sim-iverilog top work-dir iverilog-wrap vvp-wrap)
|
|
(let* ((command-file (path+ work-dir (format "~a.vc" top)))
|
|
(exe-file (path+ work-dir (format "~a.out" top)))
|
|
(vcd-file (path+ work-dir (format "~a.vcd" top)))
|
|
(cmds `(,(format "~a -g2012 -s __~a__ -o ~a -c~a"
|
|
(wrap-exe IVERILOG-EXE iverilog-wrap)
|
|
top exe-file command-file)
|
|
,(format "~a -N ~a" (wrap-exe VVP-EXE vvp-wrap) exe-file))))
|
|
|
|
(let-values (((status log)
|
|
(exec-sequence cmds)))
|
|
(if (zero? status)
|
|
(values status log (vcd-file-read
|
|
vcd-file
|
|
(lambda (sig)
|
|
(>= (length (vcd-signal-scope sig)) 2))))
|
|
(values status log #f)))))
|
|
|
|
;;;
|
|
;;; Compile sources and execute simulation with Verilator
|
|
;;; Returns (values status log vcd)
|
|
;;;
|
|
(define (exec-sim-verilator top work-dir verilator-wrap verilator-sim-wrap)
|
|
(let* ((command-file (path+ work-dir (format "~a.vc" top)))
|
|
(vcd-file (path+ work-dir (format "~a.vcd" top)))
|
|
(cmds `(,(format "~a -f ~a"
|
|
(wrap-exe VERILATOR-EXE verilator-wrap)
|
|
command-file)
|
|
,(wrap-exe (path+ work-dir (format "~a/~a" top top))
|
|
verilator-sim-wrap))))
|
|
|
|
(let-values (((status log)
|
|
(exec-sequence cmds)))
|
|
(if (zero? status)
|
|
(values status log (vcd-file-read
|
|
vcd-file
|
|
(lambda (sig)
|
|
(>= (length (vcd-signal-scope sig)) 2))))
|
|
(values status log #f)))))
|
|
|
|
;;;
|
|
;;; Execute simulation
|
|
;;;
|
|
(define* (exec-sim simulator code base top #:key
|
|
(vvp-wrap "") (iverilog-wrap "") (metatop "")
|
|
(verilator-wrap "") (verilator-sim-wrap "")
|
|
(verilator-cpp "") (verilator-build-jobs 0))
|
|
(let-values
|
|
(((work-dir status log vcd)
|
|
(cond
|
|
;; Run Icarus Verilog
|
|
((eq? simulator 'iverilog)
|
|
(let ((work-dir (make-iverilog-workdir code metatop base top)))
|
|
(let-values (((status log vcd)
|
|
(exec-sim-iverilog top work-dir iverilog-wrap vvp-wrap)))
|
|
(values work-dir status log vcd))))
|
|
|
|
;; Run Verilator
|
|
((eq? simulator 'verilator)
|
|
(let ((work-dir (make-verilator-workdir code verilator-cpp verilator-build-jobs base top)))
|
|
(let-values (((status log vcd)
|
|
(exec-sim-verilator top work-dir verilator-wrap verilator-sim-wrap)))
|
|
(values work-dir status log vcd))))
|
|
|
|
;; Inknown simulator
|
|
(else
|
|
(values #f #f #f #f)))))
|
|
|
|
(if (not work-dir)
|
|
(values ("ERROR: Unknown simulator") #f)
|
|
(begin
|
|
;; Delete work dir
|
|
(when DELETE-WORK-DIR
|
|
(delete-recursive work-dir))
|
|
|
|
;; Return (values log vcd)
|
|
(values
|
|
(string-append
|
|
log
|
|
(format "-----------------\nSimulation complete~a\n"
|
|
(if (zero? status) " succesfully"" with errors")))
|
|
vcd)))))
|
|
|
|
;;;
|
|
;;; Get app version
|
|
;;;
|
|
(define* (app-version exe #:optional (option "--version"))
|
|
(let-values (((status out)
|
|
(system-to-string-list
|
|
(format "~a ~a" exe option))))
|
|
(if (and (zero? status)
|
|
(not (null? out)))
|
|
(car out)
|
|
"Unknown")))
|
|
|
|
;;;
|
|
;;; Get storage dir from URI
|
|
;;;
|
|
(define (get-storage-dir uri root-path)
|
|
(string-trim-both
|
|
(substring (uri-path uri)
|
|
(string-length root-path))
|
|
#\/))
|
|
|
|
;;;
|
|
;;; Check storage path validity
|
|
;;;
|
|
(define (storage-dir-valid? dir)
|
|
(if (or (< (string-length dir) 1)
|
|
(> (string-length dir) 32))
|
|
#f
|
|
(string-fold
|
|
(lambda (c valid)
|
|
(if (or (char-alphabetic? c)
|
|
(char-numeric? c)
|
|
(char=? c #\-))
|
|
valid #f))
|
|
#t dir)))
|
|
|
|
;;;
|
|
;;; Check storage exists
|
|
;;;
|
|
(define (storage-path-exists? path)
|
|
(let ((dir-stat (stat path #f))
|
|
(file-stat (stat (path+ path SNIPPET-FILE) #f)))
|
|
(and dir-stat file-stat
|
|
(eq? (stat:type dir-stat) 'directory)
|
|
(eq? (stat:type file-stat) 'regular)
|
|
(not (zero? (logand #o444 (stat:perms file-stat))))
|
|
(not (zero? (logand #o222 (stat:perms file-stat)))))))
|
|
|
|
;;;
|
|
;;; Save code to storage
|
|
;;;
|
|
(define (save-to-storage path code)
|
|
(with-output-to-file (path+ path SNIPPET-FILE)
|
|
(cut display code)))
|
|
|
|
;;;
|
|
;;; Read from storage
|
|
;;;
|
|
(define (read-from-storage path)
|
|
(call-with-input-file (path+ path SNIPPET-FILE)
|
|
get-string-all))
|
|
|
|
;;;
|
|
;;; Make log HTML
|
|
;;;
|
|
(define* (make-log-html log vcd canvas-width #:key
|
|
(minimum-sample-width 10)
|
|
(maximum-canvas-width 20000))
|
|
(if vcd
|
|
(let ((need-width
|
|
(* minimum-sample-width
|
|
(length (vcd-timestamps vcd)))))
|
|
(format "~a<br/>\n<pre id=\"log\">~a</pre>\n"
|
|
(string-concatenate
|
|
(vcd->svg vcd
|
|
(if (< need-width canvas-width)
|
|
canvas-width
|
|
(if (> need-width maximum-canvas-width)
|
|
maximum-canvas-width
|
|
need-width))))
|
|
log))
|
|
(format "<pre>~a</pre>\n" log)))
|
|
|
|
;;;
|
|
;;; Web page handler
|
|
;;;
|
|
(define (make-page-handler host root index-file
|
|
work-base stor-base
|
|
max-code-size sanitize
|
|
iverilog-wrap vvp-wrap
|
|
verilator-wrap verilator-sim-wrap verilator-build-jobs)
|
|
|
|
(let* ((root-path (split-and-decode-uri-path root))
|
|
(root (encode-and-join-uri-path root-path))
|
|
(iverilog-path (append root-path `(,URI-IVERILOG)))
|
|
(verilator-path (append root-path `(,URI-VERILATOR)))
|
|
(savecode-path (append root-path `(,URI-SAVE-CODE)))
|
|
(index-html
|
|
(read-template-text
|
|
index-file
|
|
`(("IVERILOGPOSTURI" ,(encode-and-join-uri-path iverilog-path))
|
|
("VERILATORPOSTURI" ,(encode-and-join-uri-path verilator-path))
|
|
("SAVECODEURI" ,(encode-and-join-uri-path savecode-path))
|
|
("HELPSTRING",
|
|
(string-concatenate
|
|
(insert-between
|
|
`("Verilog Playground by Punzik (c) 2022"
|
|
""
|
|
,(format "Icarus: ~a"
|
|
(app-version (wrap-exe IVERILOG-EXE iverilog-wrap) "-V"))
|
|
,(format "Verilator: ~a"
|
|
(app-version (wrap-exe VERILATOR-EXE verilator-wrap)))
|
|
""
|
|
"Rules:"
|
|
"0. Don't fool around ;)"
|
|
"1. The top module must be named 'testbench'."
|
|
"2. Code size should not exceed 10000 characters."
|
|
"3. Code execution time no longer than 5 seconds.")
|
|
"\\n"))))))
|
|
(iverilog-metatop
|
|
(call-with-input-file IVERILOG-METATOP-FILE get-string-all))
|
|
(verilator-cpp
|
|
(call-with-input-file VERILATOR-CPP-FILE get-string-all)))
|
|
|
|
(lambda (request request-body)
|
|
(let (;; Requested resource path
|
|
(path (split-and-decode-uri-path
|
|
(uri-path
|
|
(request-uri request))))
|
|
|
|
;; Snippet dir path relative to stor-base
|
|
(ref-stor-dir
|
|
(let ((ref (assoc 'referer (request-headers request))))
|
|
(and ref
|
|
(let ((p (get-storage-dir (cdr ref) root)))
|
|
(and (storage-dir-valid? p)
|
|
(storage-path-exists? (path+ stor-base p))
|
|
p)))))
|
|
|
|
;; Body of the POST request
|
|
(code
|
|
(if request-body
|
|
(let ((code (utf8->string request-body)))
|
|
(if (or (zero? max-code-size)
|
|
(<= (string-length code) max-code-size))
|
|
code
|
|
(substring code 0 max-code-size)))
|
|
""))
|
|
|
|
;; Request query
|
|
(query (let ((q (uri-query (request-uri request))))
|
|
(if q
|
|
(map (lambda (qstr) (string-split q #\=))
|
|
(string-split q #\;))
|
|
'()))))
|
|
|
|
(logger LOG-VERBOSE "Request ~a:~a" (request-method request) path)
|
|
(logger LOG-VERBOSE "Request query:~a" query)
|
|
(logger LOG-DBG " stor:'~a' len:~a/~a"
|
|
ref-stor-dir
|
|
(request-content-length request)
|
|
(string-length code))
|
|
|
|
(cond
|
|
;;
|
|
;; ---- GET requests
|
|
;;
|
|
((eq? 'GET (request-method request))
|
|
(cond
|
|
;; Index page
|
|
((equal? path root-path)
|
|
(logger LOG-DBG "Request index page")
|
|
(make-response
|
|
(substitute index-html "@~a@" `((CODE ,DEFAULT-CODE)))))
|
|
|
|
;; Site favicon
|
|
((equal? path (append root-path '("favicon.ico")))
|
|
(logger LOG-DBG "Request favicon.ico")
|
|
(file-response "favicon.png"
|
|
#:content-type 'image/png
|
|
#:max-file-size 10000))
|
|
|
|
;; Get saved snippet
|
|
((and (= (length path)
|
|
(+ (length root-path) 1))
|
|
(every equal? path root-path))
|
|
(logger LOG-DBG "Request code from storage")
|
|
(let ((code
|
|
(if (null? path)
|
|
DEFAULT-CODE
|
|
(let* ((stor-dir (last path))
|
|
(stor-path (path+ stor-base stor-dir)))
|
|
(if (and (storage-dir-valid? stor-dir)
|
|
(storage-path-exists? stor-path))
|
|
(read-from-storage stor-path)
|
|
DEFAULT-CODE)))))
|
|
(make-response
|
|
(substitute index-html "@~a@" `((CODE ,code))))))
|
|
|
|
;; Wrong GET request
|
|
(else
|
|
(logger LOG-DBG "Wrong GET request")
|
|
(not-found request))))
|
|
|
|
;;
|
|
;; ---- POST requests
|
|
;;
|
|
((eq? 'POST (request-method request))
|
|
(cond
|
|
;; Run simulation
|
|
((or (equal? path iverilog-path)
|
|
(equal? path verilator-path))
|
|
(let ((simulator
|
|
(if (equal? path iverilog-path)
|
|
'iverilog
|
|
'verilator)))
|
|
|
|
(logger LOG-DBG "Request ~a simulation" (symbol->string simulator))
|
|
(let-values
|
|
(((log vcd)
|
|
(exec-sim simulator
|
|
(if sanitize (sanitize-verilog code) code)
|
|
work-base
|
|
TOP-MODULE
|
|
#:metatop iverilog-metatop
|
|
#:vvp-wrap vvp-wrap
|
|
#:iverilog-wrap iverilog-wrap
|
|
#:verilator-wrap verilator-wrap
|
|
#:verilator-sim-wrap verilator-sim-wrap
|
|
#:verilator-cpp verilator-cpp
|
|
#:verilator-build-jobs verilator-build-jobs)))
|
|
|
|
(let ((canvas-width
|
|
(let ((v (assoc "width" query)))
|
|
(or (and v (string->number (cadr v)))
|
|
DEFAULT-CANVAS-WIDTH))))
|
|
(make-response
|
|
(make-log-html log vcd canvas-width)
|
|
#:content-type 'text/plain)))))
|
|
|
|
;; Save snippet
|
|
((or (equal? path savecode-path))
|
|
(logger LOG-DBG "Request code saving")
|
|
(let ((old-code
|
|
(if ref-stor-dir
|
|
(read-from-storage (path+ stor-base ref-stor-dir))
|
|
DEFAULT-CODE)))
|
|
(if (equal? code old-code)
|
|
;; If code is not changed do nothing
|
|
(make-response
|
|
(encode-and-join-uri-path
|
|
(append root-path `(,ref-stor-dir)))
|
|
#:content-type 'text/plain)
|
|
;; New code save to new location
|
|
(let ((stor-dir
|
|
(basename
|
|
(mkdtemp
|
|
(path+
|
|
stor-base
|
|
(if USE-TIME-IN-SAVE-URL
|
|
(format "~a-XXXXXX" (current-time))
|
|
"XXXXXX"))))))
|
|
(save-to-storage (path+ stor-base stor-dir) code)
|
|
(make-response
|
|
(encode-and-join-uri-path
|
|
(append root-path `(,stor-dir)))
|
|
#:content-type 'text/plain)))))
|
|
|
|
;; Wrong POST request
|
|
(else
|
|
(logger LOG-DBG "Wrong POST request")
|
|
(not-found request))))
|
|
|
|
;;
|
|
;; ---- Unknown requests type
|
|
;;
|
|
(else
|
|
(logger LOG-DBG "Wrong request method")
|
|
(not-found request)))))))
|
|
|
|
;;;
|
|
;;; ----------------------------------------------------------------------
|
|
;;; ------------------------------- MAIN ---------------------------------
|
|
;;; ----------------------------------------------------------------------
|
|
;;;
|
|
|
|
(define (print-help app-name)
|
|
(define (-> . args)
|
|
(display (apply format args) (current-error-port))
|
|
(newline (current-error-port)))
|
|
(let ((app-name (basename app-name)))
|
|
(with-output-to-port (current-error-port)
|
|
(lambda ()
|
|
(-> "Usage: ~a [OPTION]..." app-name)
|
|
(-> "Start Verilog playground WEB server")
|
|
(-> "")
|
|
(-> "Options:")
|
|
(-> " -a, --addr ADDR Listen on ADDR address. Default: 127.0.0.1")
|
|
(-> " -p, --port PORT Listen on PORT port. Default: 8080")
|
|
(-> " -s, --host URL Run on URL hostname. Default: http://127.0.0.1:8080")
|
|
(-> " -r, --root URN Service location root. Default: ''")
|
|
(-> " --iverilog-wrap PATH Icarus compiler wrapper.")
|
|
(-> " --vvp-wrap PATH Icarus Verilog interpreter wrapper.")
|
|
(-> " --verilator-wrap PATH Verilator compiler wrapper.")
|
|
(-> " --verilator-sim-wrap PATH Verilator simulation executable wrapper.")
|
|
(-> " --verilator-build-jobs N Verilator parallel build.")
|
|
(-> " --max-len LEN Set maximum code size in symbols. Default: 0 (infinite)")
|
|
(-> " --dont-sanitize Do not sanitize verilog code (dangerous)")
|
|
(-> " --work-base PATH Set work base path. Default: ./")
|
|
(-> " --stor-base PATH Set snippets storage path. Default: ./")
|
|
(-> " --log-level LEVEL Set log level from 0 (quiet) to 10 (verbose). Default: 1./")
|
|
(-> " -h, --help Print this message and exit")
|
|
(-> "")
|
|
(-> "Source code and issue tracker: <https://github.com/punzik/>")))))
|
|
|
|
(define (string-trim-if-string str)
|
|
(if (string? str)
|
|
(string-trim-both str)
|
|
str))
|
|
|
|
(define (main args)
|
|
(debug-disable 'backtrace)
|
|
(let-values
|
|
(((opts rest err)
|
|
(parse-opts (cdr args)
|
|
'(("addr" #\a) required)
|
|
'(("port" #\p) required)
|
|
'(("host" #\s) required)
|
|
'(("root" #\r) required)
|
|
'(("vvp-wrap") required)
|
|
'(("iverilog-wrap") required)
|
|
'(("verilator-wrap") required)
|
|
'(("verilator-sim-wrap") required)
|
|
'(("verilator-build-jobs") required)
|
|
'(("max-len") required)
|
|
'(("dont-sanitize") none)
|
|
'(("work-base") required)
|
|
'(("stor-base") required)
|
|
'(("log-level") required)
|
|
'(("help" #\h) none))))
|
|
|
|
(let ((addr (string-trim-both (or (option-get opts "addr") "127.0.0.1")))
|
|
(port (string->number (string-trim-both (or (option-get opts "port") "8080"))))
|
|
(host (string-trim-both (or (option-get opts "host") "http://127.0.0.1:8080")))
|
|
(root (string-trim-both (or (option-get opts "root") "")))
|
|
(vvp-wrap (string-trim-if-string (option-get opts "vvp-wrap")))
|
|
(iverilog-wrap (string-trim-if-string (option-get opts "iverilog-wrap")))
|
|
(verilator-wrap (string-trim-if-string (option-get opts "verilator-wrap")))
|
|
(verilator-sim-wrap (string-trim-if-string (option-get opts "verilator-sim-wrap")))
|
|
(verilator-build-jobs (string->number (string-trim-both (or (option-get opts "verilator-build-jobs") "0"))))
|
|
(max-code-size (string->number (string-trim-both (or (option-get opts "max-len") "0"))))
|
|
(sanitize (not (option-get opts "dont-sanitize")))
|
|
(work-base (string-trim-both (or (option-get opts "work-base") "./")))
|
|
(stor-base (string-trim-both (or (option-get opts "stor-base") "./")))
|
|
(log-level (string->number (string-trim-both (or (option-get opts "log-level") "1")))))
|
|
|
|
(cond
|
|
(err
|
|
(display (format "Unknown option '~a'\n" err))
|
|
(print-help (car args))
|
|
(exit -1))
|
|
|
|
((option-get opts "help")
|
|
(print-help (car args))
|
|
(exit -1))
|
|
|
|
(else
|
|
(set! LOG-LEVEL log-level)
|
|
(logger LOG-INFO "Listen on '~a' port '~a'" addr port)
|
|
(logger LOG-INFO "Server URL: '~a/~a'" host root)
|
|
(logger LOG-INFO "iverilog wrapper: '~a'" iverilog-wrap)
|
|
(logger LOG-INFO "vvp wrapper: '~a'" vvp-wrap)
|
|
(logger LOG-INFO "verilator compiler wrapper: '~a'" verilator-wrap)
|
|
(logger LOG-INFO "verilator simulator wrapper: '~a'" verilator-sim-wrap)
|
|
(logger LOG-INFO "verilator build jobs: ~a" verilator-build-jobs)
|
|
(logger LOG-INFO "Max code size: ~a" max-code-size)
|
|
(logger LOG-INFO "Sanitize code: ~a" sanitize)
|
|
(logger LOG-INFO "Work base path: '~a'" work-base)
|
|
(logger LOG-INFO "Storage base path: '~a'" stor-base)
|
|
(logger LOG-INFO "Log level: '~a'" log-level)
|
|
|
|
(run-server
|
|
(make-page-handler host root INDEX-FILE
|
|
work-base stor-base
|
|
max-code-size sanitize
|
|
iverilog-wrap vvp-wrap
|
|
verilator-wrap verilator-sim-wrap verilator-build-jobs)
|
|
'http `(#:host ,addr #:port ,port)))))))
|