From ab5db7f6e8a478202c885cdf5dd7b3f44f1a5c0f Mon Sep 17 00:00:00 2001
From: Nikolay Puzanov <np@embddr.com>
Date: Wed, 7 Dec 2022 17:00:51 +0300
Subject: [PATCH] Add waveforms

---
 _web_server/server/index.html            |  46 +++-
 _web_server/server/playground-server.scm | 329 +++++++++++++----------
 2 files changed, 221 insertions(+), 154 deletions(-)

diff --git a/_web_server/server/index.html b/_web_server/server/index.html
index 18e3906..127e879 100644
--- a/_web_server/server/index.html
+++ b/_web_server/server/index.html
@@ -63,6 +63,36 @@
           overflow: scroll;
       }
 
+      svg {
+          fill: none;
+          stroke: white;
+          stroke-width: 0;
+          shape-rendering: crispEdges;
+      }
+
+      svg #wave-signals {
+          stroke: #00fcff;
+          stroke-width: 1;
+      }
+
+      svg #wave-clock {
+          stroke: #fffe9a;
+          stroke-width: 1;
+      }
+
+      svg #wave-delim {
+          stroke: #d0d0d0;
+          stroke-width: 2;
+      }
+
+      svg text {
+          font-family: 'JetBrains Mono', monospace;
+          font-size: 14px;
+          fill: white;
+      }
+
+      svg #wave-background { fill: #1e2426; }
+
       @media (orientation: landscape) and (not (pointer: coarse)) {
           body {
               display: flex;
@@ -83,11 +113,6 @@
               width: 50%;
               height: 100%;
           }
-
-          #log {
-              position: absolute;
-              height: 100%;
-          }
       }
     </style>
   </head>
@@ -100,16 +125,14 @@
       Sim:
       <button onclick="send_to_sim('%IVERILOGPOSTURI%')"><span class="text">Icarus</span></button>
       <button onclick="send_to_sim('%VERILATORPOSTURI%')"><span class="text">Verilator</span></button>
-      <!-- button><span class="text">Verilator</span></button -->
     </div>
 
     <div id="text">
       <div id="editor">@CODE@</div>
-      <div id="logdiv">
-        <pre id="log"></pre>
-      </div>
+      <div id="logdiv"></div>
     </div>
 
+
     <script src="https://cdnjs.cloudflare.com/ajax/libs/ace/1.13.1/ace.js" type="text/javascript" charset="utf-8"></script>
     <script src="https://cdnjs.cloudflare.com/ajax/libs/ace/1.13.1/ext-language_tools.js" type="text/javascript" charset="utf-8"></script>
     <script type="text/javascript" charset="utf-8">
@@ -123,10 +146,11 @@
           enableBasicAutocompletion : true,
           enableLiveAutocompletion : true
       });
-      const log_area = document.getElementById('log');
+      const log_area = document.getElementById('logdiv');
       function send_to_sim(uri) {
+          query = uri + "?width=" + log_area.clientWidth;
           log_area.innerHTML = "Please wait...";
-          fetch(uri,
+          fetch(query,
                 {
                     method: 'POST',
                     headers: {
diff --git a/_web_server/server/playground-server.scm b/_web_server/server/playground-server.scm
index ef06232..34983c5 100755
--- a/_web_server/server/playground-server.scm
+++ b/_web_server/server/playground-server.scm
@@ -57,6 +57,8 @@
    "  end\n"
    "endmodule\n"))
 
+(define DEFAULT-CANVAS-WIDTH 800)
+
 (define (multistring . strings)
   (apply string-append
          (insert-between strings "\n")))
@@ -223,7 +225,7 @@
          (half-dy (/ (- y1 y0) 2))
          (id (if id (format " id=\"~a\"" id) "")))
 
-    (let next-sample ((samples (append (vcd-signal-get signal) `((,tend . "-"))))
+    (let next-sample ((samples (vcd-signal-get signal))
                       (value (if (eq? sig-type 'real)
                                  0
                                  (make-string sig-width #\x)))
@@ -234,9 +236,10 @@
           svg
           (let ((sample-time (car (car samples)))
                 (sample-value (cdr (car samples))))
-            (if (or (< (- sample-time time) time-per-pixel)
-                    (and (equal? value sample-value)
-                         (not (eq? sig-type 'event))))
+            (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)
@@ -300,7 +303,7 @@
                                         y0
                                         (- x1 x0 (* data-hw 2))
                                         (- y1 y0))
-                           (format-inex "<text id=\"val\" x=\"~a\" y=\"~a\">" 0 text-position)
+                           (format-inex "<text x=\"~a\" y=\"~a\">" 0 text-position)
                            (if (or (eq? sig-type 'real)
                                    (< sig-width 4))
                                value
@@ -308,11 +311,7 @@
                                 (vcd-binary->hex value #t)))
                            "</text></svg>"))))
 
-                   ;; Real number
-                   ((eq? sig-type 'real)
-                    "")
-
-                   ;; Event
+                   ;; Event TODO
                    ((eq? sig-type 'event)
                     ""))
                   svg))))))))
@@ -335,7 +334,7 @@
 ;;;
 (define* (vcd->svg vcd width #:key
                    (signal-height 15)
-                   (signal-text-position 12)
+                   (signal-text-position 13)
                    (margin 5)
                    (signal-spacing 5)
                    (legend-width 100)
@@ -358,59 +357,62 @@
                      (string-ci<? (vcd-signal-name a)
                                   (vcd-signal-name b)))))))
 
-    (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
-       (list
-        (format-inex "<svg width=\"~a\" height=\"~a\"" width height)
-        (format "preserveAspectRatio=\"xMidYMin slice\" role=\"img\"")
-        (format "<g id=\"wave-background\"><rect width=\"100%\" height=\"100%\"/></g>")
-        (format "<g id=\"wave-signals\">"))
-
-       ;; Legend
-       `(,(format-inex "<svg id=\"legend\" x=\"~a\" y=\"~a\" width=\"~a\" height=\"~a\">"
-                       margin margin legend-width (- height (* 2 margin))))
-       (signals->legend signals
-                        (+ signal-height signal-spacing)
-                        signal-text-position)
-       '("</svg>")
-
-       ;; Clock
-       (signal->svg (car signals) tstart tend
-                    signals-x margin
-                    signals-w signal-height signal-text-position
-                    #:id "clock")
-
-       ;; Rest
-       (fold
-        (lambda (sig n out)
-          (append
-           out
-           (signal->svg sig tstart tend
-                        signals-x
-                        (+ margin
-                           (* n signal-height)
-                           (* n signal-spacing))
-                        signals-w signal-height signal-text-position)))
+    (if (<= tend tstart)
         '()
-        (cdr signals)
-        (iota (length
-               (cdr signals))
-              1))
+        (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)))))
 
-       ;; Delimiter
-       `(,(format-inex "<path id=\"delim\" d=\"M~a ~a v~a\"/>"
-                       (+ legend-width (* 2 margin)) (- margin extra-delim-y)
-                       (- height (* 2 (- margin extra-delim-y)))))
+          (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>"))
 
-       ;; Close svg tag
-       '("</svg>")))))
+           ;; 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
@@ -561,57 +563,79 @@
           (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)
+;;; 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))))
-    ;; Compile
-    (let ((cmdline (format "~a -g2012 -s __~a__ -o ~a -c~a"
-                           (wrap-exe IVERILOG-EXE iverilog-wrap)
-                           top exe-file command-file)))
-      (let-values (((status out time)
-                    (system-to-string-with-time cmdline)))
-        (let ((compile-log
-               (exe-log-pretty cmdline status out time)))
-          (if (not (zero? status))
-              (values status compile-log)
+  (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))))
 
-              ;; Execute
-              (let ((cmdline (format "~a -N ~a" (wrap-exe VVP-EXE vvp-wrap) exe-file)))
-                (let-values (((status out time)
-                              (system-to-string-with-time cmdline)))
-                  (let ((execution-log
-                         (exe-log-pretty cmdline status out time)))
-                    (values status (string-append compile-log execution-log)))))))))))
+    (let-values (((status log)
+                  (exec-sequence cmds)))
+      (if (zero? status)
+          (values status log (vcd-file-read
+                              vcd-file
+                              (lambda (sig)
+                                (= 2 (length (vcd-signal-scope sig))))))
+          (values status log #f)))))
 
 ;;;
 ;;; Compile sources and execute simulation with Verilator
-;;; Returns (values status log)
+;;; Returns (values status log vcd)
 ;;;
 (define (exec-sim-verilator top work-dir verilator-wrap verilator-sim-wrap)
-  ;; Compile
   (let* ((command-file (path+ work-dir (format "~a.vc" top)))
-         (cmdline (format "~a -f ~a"
+         (vcd-file (path+ work-dir (format "~a.vcd" top)))
+         (cmds `(,(format "~a -f ~a"
                           (wrap-exe VERILATR-EXE verilator-wrap)
-                          command-file)))
-    (let-values (((status out time)
-                  (system-to-string-with-time cmdline)))
-      (let ((compile-log
-             (exe-log-pretty cmdline status out time)))
-        (if (not (zero? status))
-            (values status compile-log)
+                          command-file)
+                 ,(wrap-exe (path+ work-dir (format "~a/~a" top top))
+                            verilator-sim-wrap))))
 
-            ;; Execute
-            (let ((cmdline (wrap-exe (path+ work-dir (format "~a/~a" top top))
-                                     verilator-sim-wrap)))
-              (let-values (((status out time)
-                            (system-to-string-with-time cmdline)))
-                (let ((execution-log
-                       (exe-log-pretty cmdline status out time)))
-                  (values status (string-append compile-log execution-log))))))))))
+    (let-values (((status log)
+                  (exec-sequence cmds)))
+      (if (zero? status)
+          (values status log (vcd-file-read
+                              vcd-file
+                              (lambda (sig)
+                                (= 2 (length (vcd-signal-scope sig))))))
+          (values status log #f)))))
 
 ;;;
 ;;; Execute simulation
@@ -621,38 +645,40 @@
                    (verilator-wrap "") (verilator-sim-wrap "")
                    (verilator-cpp "") (verilator-build-jobs 0))
   (let-values
-      (((work-dir status log)
+      (((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)
+            (let-values (((status log vcd)
                           (exec-sim-iverilog top work-dir iverilog-wrap vvp-wrap)))
-              (values work-dir status log))))
+              (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)
+            (let-values (((status log vcd)
                           (exec-sim-verilator top work-dir verilator-wrap verilator-sim-wrap)))
-              (values work-dir status log))))
+              (values work-dir status log vcd))))
 
          ;; Inknown simulator
          (else
-          (values #f #f #f)))))
+          (values #f #f #f #f)))))
 
     (if (not work-dir)
-        ("ERROR: Unknown simulator")
+        (values ("ERROR: Unknown simulator") #f)
         (begin
           ;; Delete work dir
           (when DELETE-WORK-DIR
             (delete-recursive work-dir))
 
-          ;; Return log
-          (string-append
-           log
-           (format "-----------------\nSimulation complete~a\n"
-                   (if (zero? status) " succesfully"" with errors")))))))
+          ;; Return (values log vcd)
+          (values
+           (string-append
+            log
+            (format "-----------------\nSimulation complete~a\n"
+                    (if (zero? status) " succesfully"" with errors")))
+           vcd)))))
 
 ;;;
 ;;; Get app version
@@ -716,6 +742,17 @@
   (call-with-input-file (path+ path SNIPPET-FILE)
     get-string-all))
 
+;;;
+;;; Make log HTML
+;;;
+(define (make-log-html log vcd canvas-width)
+  (if vcd
+      (format "~a<br/>\n<pre id=\"log\">~a</pre>\n"
+              (string-concatenate
+               (vcd->svg vcd canvas-width))
+              log)
+      (format "<pre>~a</pre>\n" log)))
+
 ;;;
 ;;; Web page handler
 ;;;
@@ -783,10 +820,17 @@
                            (<= (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" (uri-query (request-uri request)))
+        (logger LOG-VERBOSE "Request query:~a" query)
         (logger LOG-DBG "  stor:'~a' len:~a/~a"
                 ref-stor-dir
                 (request-content-length request)
@@ -838,40 +882,39 @@
          ;;
          ((eq? 'POST (request-method request))
           (cond
-           ;; Run iverilog simulation
-           ((equal? path iverilog-path)
-            (logger LOG-DBG "Request iverilog simulation")
+           ;; Run simulation
+           ((or (equal? path iverilog-path)
+                (equal? path verilator-path))
+            (let ((simulator
+                   (if (equal? path iverilog-path)
+                       'iverilog
+                       'verilator)))
 
-            (when ref-stor-dir
-              (save-to-storage (path+ stor-base ref-stor-dir) code))
+              (logger LOG-DBG "Request ~a simulation" (symbol->string simulator))
 
-            (make-response
-             (exec-sim 'iverilog
-                       (if sanitize (sanitize-verilog code) code)
-                       work-base
-                       TOP-MODULE
-                       #:metatop iverilog-metatop
-                       #:vvp-wrap vvp-wrap
-                       #:iverilog-wrap iverilog-wrap)
-             #:content-type 'text/plain))
+              (when ref-stor-dir
+                (save-to-storage (path+ stor-base ref-stor-dir) code))
 
-           ;; Run verilator simulation
-           ((equal? path verilator-path)
-            (logger LOG-DBG "Request verilator simulation")
+              (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)))
 
-            (when ref-stor-dir
-              (save-to-storage (path+ stor-base ref-stor-dir) code))
-
-            (make-response
-             (exec-sim 'verilator
-                       (if sanitize (sanitize-verilog code) code)
-                       work-base
-                       TOP-MODULE
-                       #:verilator-wrap verilator-wrap
-                       #:verilator-sim-wrap verilator-sim-wrap
-                       #:verilator-cpp verilator-cpp
-                       #:verilator-build-jobs verilator-build-jobs)
-             #:content-type 'text/plain))
+                (let ((canvas-width
+                       (let ((v (assoc "width" query)))
+                         (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)