From 8b4ae738a14c37c87c6498e1af11f70c47dde411 Mon Sep 17 00:00:00 2001 From: Nikolay Puzanov Date: Thu, 7 Jul 2022 20:00:14 +0300 Subject: [PATCH] Add version 0.0.1 --- utest.scm | 867 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 867 insertions(+) create mode 100755 utest.scm diff --git a/utest.scm b/utest.scm new file mode 100755 index 0000000..81b2960 --- /dev/null +++ b/utest.scm @@ -0,0 +1,867 @@ +#!/usr/bin/env guile +!# + +;; Copyright (c) 2022 Nikolay Puzanov +;; Permission is hereby granted, free of charge, to any person obtaining a copy +;; of this software and associated documentation files (the "Software"), to deal +;; in the Software without restriction, including without limitation the rights +;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +;; copies of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: + +;; The above copyright notice and this permission notice shall be included in +;; all copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +;; THE SOFTWARE. + +;; -*- geiser-scheme-implementation: guile -*- + +(import + ;; (scheme base) ; R7RS base (not needed for Guile) + (srfi srfi-1) ; Lists + (srfi srfi-9) ; Records + (srfi srfi-11) ; let-values + (srfi srfi-13) ; String library + (srfi srfi-28) ; Simple format + (srfi srfi-39)) ; Parameters + +(use-modules + (ice-9 regex) + (ice-9 popen) + (ice-9 textual-ports) + (ice-9 threads) + (ice-9 getopt-long)) + +(define APP_VERSION "0.0.1") + +(define MAKEFILE_NAME_REGEXP ".*\\.utest$") +(define TIMEOUT_MODULE_NAME "utest_timeout") +(define DUMP_MODULE_NAME "utest_dump") +(define WORK_DIR_PREFIX "") + +;;; Globals +(define utest/force-dump (make-parameter #f)) +(define utest/restart-dump (make-parameter #f)) +(define utest/keep-output (make-parameter #f)) +(define utest/verbose (make-parameter #f)) +(define utest/nocolor (make-parameter #f)) +(define utest/base-path (make-parameter "")) +(define utest/work-path (make-parameter "")) + +(define-record-type + (log-type log-prefix color out-prefix verbose) + log-type? + (log-prefix lt-log-prefix) + (color lt-color) + (out-prefix lt-out-prefix) + (verbose lt-verbose)) + +(define LOG_PREFIX_INFO "INFO#") +(define LOG_PREFIX_WARN "WARN#") +(define LOG_PREFIX_FAIL "FAIL#") + +(define log-types + `((info ,(log-type LOG_PREFIX_INFO 15 " | " #t)) + (warning ,(log-type LOG_PREFIX_WARN 226 " + " #t)) + (error ,(log-type LOG_PREFIX_FAIL 196 " + " #t)) + (test-head ,(log-type "TSTH#" 14 "" #t)) + (test-info ,(log-type "TSTI#" 6 "" #t)) + (test-succ ,(log-type "TSTS#" 47 "" #t)) + (test-fail ,(log-type "TSTF#" 196 "" #t)))) + +(define log-type-default + (log-type "" 244 " | " #f)) + +;;; Like assoc but with functional predicate +(define (assf f l) + (find (lambda (x) (f (car x))) l)) + +;;; Get log type by id (level) +(define (log-type-by-id id) + (let ((t (assq id log-types))) + (if t (cadr t) log-type-default))) + +;;; Get log type with log-prefix matched to prefix of str +(define (log-type-by-prefix str) + (let ((t (assf (lambda (x) (string-prefix? x str)) + (map (lambda (x) (let ((t (cadr x))) + (list (lt-log-prefix t) t))) + log-types)))) + (if t (cadr t) log-type-default))) + +;;; Useful print functions +(define (printf . rest) (display (apply format rest))) +(define (println . rest) (for-each (lambda (x) (display x) (newline)) rest)) + +;;; Return log line as string +(define (utest/slog a . args) + (if (string? a) + (apply format a args) + (string-append + (lt-log-prefix (log-type-by-id a)) + (apply format args)))) + +;;; Display log line +;;; Split line by newline character and display +;;; each piece as seperate line. +(define (utest/log a . args) + (let* ((pre (if (string? a) "" (lt-log-prefix (log-type-by-id a)))) + (fmt (if (string? a) (cons a args) args)) + (strs + (map (lambda (x) (string-append pre x)) + (string-split + (apply format fmt) + #\newline)))) + (for-each println strs) #t)) + +;;; +;;; Colorize text +;;; +(define* (color text fg #:optional (bg 'default)) + (format "~a~a~a~a[0m" + ;; Foreground + (if (number? fg) + (format "~a[38;5;~am" #\esc fg) + (format "~a[~am" #\esc (case fg + ((black) "30") + ((red) "31") + ((green) "32") + ((yellow) "33") + ((blue) "34") + ((magenta) "35") + ((cyan) "36") + ((white) "37") + ((default) "39")))) + ;; Background + (if (number? bg) + (format "~a[48;5;~am" #\esc bg) + (format "~a[~am" #\esc (case bg + ((black) "40") + ((red) "41") + ((green) "42") + ((yellow) "43") + ((blue) "44") + ((magenta) "45") + ((cyan) "46") + ((white) "47") + ((default) "49")))) + text #\esc)) + +;;; +;;; Print log +;;; +(define (convert-log-item item colorize) + (let* ((t (log-type-by-prefix item)) + (pre (lt-out-prefix t)) + (str (substring item (string-length (lt-log-prefix t))))) + (string-append + pre + (if colorize + (color str (lt-color t)) + str)))) + +(define* (print-log log-strings + #:key + (verbose #f) + (colorize #f)) + (for-each + (lambda (str) + (let ((t (log-type-by-prefix str))) + (when (or verbose (lt-verbose t)) + (println (convert-log-item str colorize))))) + log-strings)) + +;;; +;;; Create file with simulation timeout watchdog +;;; +(define (create-timeout-module path modname timeout) + (define (* . fmt) (println (apply format fmt))) + (let ((filename (format "~a/~a.v" path modname))) + (with-output-to-file filename + ;; #:exists 'replace + (lambda () + (* "// Automatically generated file") + (* "`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(\"~aTimeout at %0t\", $time);" + (lt-log-prefix (log-type-by-id 'error))) + (* " $finish;") + (* " end") + (* "endmodule"))) + (canonicalize-path filename))) + +;;; +;;; Create dump module +;;; +(define (create-dump-module path modname top dump-type) + (define (* . fmt) (println (apply format fmt))) + (let ((filename (format "~a/~a.v" path modname))) + (with-output-to-file filename + ;; #:exists 'replace + (lambda () + (* "// Automatically generated file") + (* "`timescale 1ps/1ps") + (* "module ~a();" modname) + (* " initial begin") + (* " $dumpfile(\"~a/~a.~a\");" path top dump-type) + (* " $dumpvars(0, ~a);" top) + (* " end") + (* "endmodule"))) + (canonicalize-path filename))) + +;;; +;;; Return directory list +;;; +(define (list-dir 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)))) + +;;; +;;; Convert path to absolute path +;;; +(define* (path->absolute path #:optional (base "")) + (canonicalize-path + (if (string-null? base) + path + (string-append base "/" path)))) + +;;; +;;; Find path items for which the function f returns true +;;; (fn fullpath type) : (-> (string symbol) boolean) +;;; Returns empty list if files not found +;;; +(define* (find-paths fn base #:optional (follow-symlink #f)) + (let ((ls (list-dir base))) + (let ((files.dirs + (fold (lambda (name f.d) + (let ((files (car f.d)) + (dirs (cdr f.d))) + (let* ((t (stat:type (stat name))) + (f (if (fn name t) (cons name files) files))) + (if (or (eq? t 'directory) + (and follow-symlink + (eq? t symlink))) + (cons f (cons name dirs)) + (cons f dirs))))) + '(()) ls))) + (let ((files (car files.dirs)) + (dirs (cdr files.dirs))) + (fold (lambda (dir files) + (append files (find-paths fn dir follow-symlink))) + files dirs))))) + +;;; +;;; Find files with name matched a regular expression +;;; (find-files-regexp rx base [follow-symlink #f]) -> (listof path?) +;;; rx : string? +;;; base : string? +;;; follow-symlink : boolean? +;;; +;;; rx - regulat expression +;;; base - base directory for files search +;;; +(define* (find-files-regexp rx base #:optional (follow-symlink #f)) + (if (eq? 'regular (stat:type (stat base))) + (if (string-match rx (basename base)) (list base) '()) + (find-paths + (lambda (f t) + (and (eq? t 'regular) + (string-match rx (basename f)))) + base follow-symlink))) + +;;; +;;; Prepare argument list +;;; #f -> '() +;;; Value -> '(Value) +;;; '(...) -> '(...) +;;; +(define (arg-to-list arg) + (cond ((not arg)'()) + ((list? arg) arg) + (else (list arg)))) + +;;; +;;; Flatten list +;;; +(define (flatten x) + (cond ((null? x) '()) + ((pair? x) (append (flatten (car x)) (flatten (cdr x)))) + (else (list x)))) + +;;; +;;; Trim list +;;; +(define (list-trim-left l pred) + (if (or (null? l) (not (pred (car l)))) + l + (list-trim-left (cdr l) pred))) + +(define (list-trim-right l pred) + (reverse (list-trim-left (reverse l) pred))) + +(define (list-trim l pred) + (list-trim-right + (list-trim-left l pred) + pred)) + +;;; +;;; Execute system command and capture stdout and stderr to string list +;;; +(define (system-to-string-list cmd) + (let* ((cmd (string-append cmd " 2>&1;")) + (p (open-input-pipe cmd)) + (out (get-string-all p))) + (values + (close-pipe p) + (list-trim (string-split out #\newline) string-null?)))) + +;;; +;;; Compile code with Icarus Verilog +;;; +(define* (iverilog-compile sources + #:key + (iverilog-executable "iverilog") + (modpaths '()) ; -y + (modtypes '(".v" ".sv")) ; -Y + (includes '()) ; -I + (top #f) ; -s + (output #f) ; -o + (lang "2012") ; -g2012 + (features '()) ; -g + (vpipaths '()) ; -L + (vpimods '()) ; -m + (libs '()) ; -l + (netlist #f) ; -N + (separate #f) ; -u + (warnings "all") ; -W + (defines '()) ; -D=X + (parameters '()) ; -P=X + (other '())) + + (let ((opts + (cons + iverilog-executable + (append + (if lang (list (format "-g~a" lang)) '()) + (if output (list "-o" output) '()) + (if separate '("-u") '()) + (if netlist (list (format "-N~a" netlist)) '()) + (flatten (map (lambda (x) (list "-s" x)) (arg-to-list top))) + (map (lambda (x) (format "-W~a" x)) (arg-to-list warnings)) + (map (lambda (x) (format "-y~a" x)) (arg-to-list modpaths)) + (map (lambda (x) (format "-Y~a" x)) (arg-to-list modtypes)) + (map (lambda (x) (format "-I~a" x)) (arg-to-list includes)) + (map (lambda (x) (format "-g~a" x)) (arg-to-list features)) + (map (lambda (x) (format "-L~a" x)) (arg-to-list vpipaths)) + (map (lambda (x) (format "-m~a" x)) (arg-to-list vpimods)) + (map (lambda (x) (format "-l~a" x)) (arg-to-list libs)) + (map (lambda (x) + (format "-P~a=~a" + (if (or (not top) (list? top)) + (car x) + (format "~a.~a" top (car x))) + (cadr x))) + parameters) + (map (lambda (x) + (if (list? x) + (format "-D~a=~a" (car x) (cadr x)) + (format "-D~a" x))) + defines) + other + (arg-to-list sources))))) + + (let ((cmdline (fold (lambda (x s) (string-append s x " ")) "" opts))) + (let-values (((status output) + (system-to-string-list cmdline))) + (values (= status 0) cmdline output))))) + +;;; +;;; Run simulation of executable compiled with Icarus Verilog +;;; +(define* (iverilog-run vvp-binary + #:key + (vvp-executable "vvp") + (vpipaths '()) ; -M + (vpimods '()) ; -m + (dumpformat 'fst) + (plusargs '())) + (let ((opts + (cons + vvp-executable + (append + (map (lambda (x) (format "-M~a" x)) (arg-to-list vpipaths)) + (map (lambda (x) (format "-m~a" x)) (arg-to-list vpimods)) + (list "-N" vvp-binary) ; $finish on CTRL-C + (case dumpformat + ((vcd) '("-vcd")) + ((fst) '("-fst")) + ((lxt) '("-lxt")) + ((lxt2) '("-lxt2")) + ((none) '("-none")) + (else '())) + (map (lambda (x) (format "+~a" x)) plusargs))))) + + (let ((cmdline (fold (lambda (x s) (string-append s x " ")) "" opts))) + (let-values (((status output) + (system-to-string-list cmdline))) + (let ((status + ;; Fix vvp issue (https://github.com/steveicarus/iverilog/issues/737) + (if (find (lambda (x) (string-prefix? "VCD Error: " x)) output) -1 status))) + (values (= status 0) cmdline output)))))) + +;;; +;;; Check log for errors or warnings +;;; +(define (check-log log) + (let ((sim-fail-prefix (lt-log-prefix (log-type-by-id 'error))) + (sim-warn-prefix (lt-log-prefix (log-type-by-id 'warning)))) + (cond + ((find (lambda (x) (string-prefix? sim-fail-prefix x)) log) #f) + ((find (lambda (x) (string-prefix? sim-warn-prefix x)) log) 'warning) + (else #t)))) + +;;; +;;; Run compile and simulation with Icarus Verilog +;;; +(define* (utest/run-simulation-iverilog sources + top + #:key + (iverilog-executable "iverilog") + (vvp-executable "vvp") + (modpaths '()) + (modtypes '(".v" ".sv")) + (includes '()) + (lang "2012") + (parameters '()) + (defines '()) + (features '()) + (separate #f) + (plusargs '()) + (vpimods '()) + (vpipaths '()) + (warnings "all") + (dumpformat 'fst) + (timeout '(1 ms))) + + ;; Get parameters + (let ((force-dump (utest/force-dump)) + (base-path (utest/base-path)) + (work-path (utest/work-path))) + + ;; Create helper modules - timeout watchdog and waveform dumper + (let ((timeout-module (create-timeout-module work-path TIMEOUT_MODULE_NAME timeout)) + (dump-module (create-dump-module work-path DUMP_MODULE_NAME top dumpformat))) + + ;; Convert relative paths to absolute + (let ((sources (append (map (lambda (x) (path->absolute x base-path)) + (arg-to-list sources)) + (list timeout-module dump-module))) + (includes (map (lambda (x) (path->absolute x base-path)) (arg-to-list includes))) + (modpaths (map (lambda (x) (path->absolute x base-path)) (arg-to-list modpaths))) + (vpipaths (map (lambda (x) (path->absolute x base-path)) (arg-to-list vpipaths))) + (execfile (format "~a/~a.vvp" work-path top))) + + (let ((succ + ;; Start compilation + (let-values + (((succ cmdl outp) + (iverilog-compile sources + #:iverilog-executable iverilog-executable #:modpaths modpaths + #:modtypes '(".v" ".sv") #:includes includes + #:top top #:other `("-s" ,TIMEOUT_MODULE_NAME "-s" ,DUMP_MODULE_NAME) + #:output execfile #:lang lang #:features features #:vpipaths vpipaths + #:vpimods vpimods #:separate separate #:warnings warnings #:defines defines + #:parameters parameters))) + + ;; Print iverilog command line and output + (printf "$ ~a\n" cmdl) + (for-each println outp) + + ;; Run simulation. On error the simulation will retry + ;; with dump enabled, if needed + (if succ + (let retry ((dump force-dump)) + (let-values + (((succ cmdl outp) + (iverilog-run execfile + #:vvp-executable vvp-executable #:vpipaths vpipaths + #:vpimods vpimods #:dumpformat (if dump dumpformat 'none) + #:plusargs plusargs))) + (let ((succ (if succ (check-log outp) succ))) + (if (or succ dump (not (utest/restart-dump))) + (begin + ;; Print vvp command line and output + (printf "$ ~a\n" cmdl) + (for-each println outp) + succ) + (retry #t))))) + succ)))) + succ))))) + +;;; +;;; Return all test procs from make files +;;; Return list of pairs (base-dir . test-proc) +;;; +(define (collect-test-procs files) + (fold + (lambda (f procs) + (let ((f (canonicalize-path f))) + (append + procs + (map (lambda (proc) (list proc (dirname f) (basename f))) + (let ((procs (load f))) + (if (list? procs) procs (list procs))))))) + '() files)) + +;;; +;;; Call test proc. Collect output to list of string +;;; +(define (call-test test work) + (let* ((pass #f) + (proc (car test)) + (base (cadr test)) + (name (proc 'name)) + (name (format "~a~a/~a" + (let* ((pwd (string-append (canonicalize-path (getcwd)) "/")) + (base-loc + (if (string-prefix? pwd base) + (substring base (string-length pwd)) + base))) + (if (string-null? base-loc) + "" + (string-append base-loc "/"))) + (caddr test) + (if name name "-"))) + (descr (proc 'description)) + (log + (string-split + (with-output-to-string + (lambda () + (utest/log 'test-head "TEST ~a" name) + (when descr (utest/log 'test-info "~a" descr)) + (utest/log "Base: ~a" base) + (utest/log "Work: ~a" work) + (set! pass + (with-exception-handler (lambda (e) + (display "EXCEPTION: ") + (display e) #f) + (lambda () + (parameterize ((utest/base-path base) + (utest/work-path work)) + (proc))) + #:unwind? #t)))) + #\newline))) + + ;; Check log + (let ((log (append log + (list (if pass + (utest/slog 'test-succ "PASS") + (utest/slog 'test-fail "FAIL (~a)" (basename work))))))) + (values pass log)))) + +;;; +;;; Create temporary working directory, call test, +;;; print log to stdout and save verbose log to a file. +;;; +;;; test : (list test-proc base-path makefile-base-name) +;;; returns: (values pass output) +;;; +(define (execute-test test) + (let ((proc (car test)) + (base (cadr test)) + (makefile-name (caddr test))) + (let* ((name (proc 'name)) + (name (if name name "noname")) + (work (mkdtemp (format "~a/~a~a-~a-~a-XXXXXX" + base WORK_DIR_PREFIX + makefile-name + (string-map (lambda (c) (if (char-whitespace? c) #\_ c)) name) + (current-time))))) + ;; Execute test + (let* ((p #f) + (o (with-output-to-string + (lambda () + (let-values (((pass log) + (call-test test work))) + (set! p pass) + + ;; Print log + (print-log log + #:colorize (not (utest/nocolor)) + #:verbose (or (utest/verbose) + (not (eq? pass #t)))) + + ;; Save log + (with-output-to-file (format "~a/test-log.txt" work) + (lambda () (print-log log #:colorize #f #:verbose #t))) + + ;; Delete work dir if test pass and no need to keep directory + (if (and (eq? pass #t) + (not (utest/force-dump)) + (not (utest/keep-output))) + (begin + (when (utest/verbose) + (printf "Delete work dir ~a\n" work)) + (delete-recursive work)) + (printf "See output at ~a\n" work))))))) + (values p o))))) + +;;; +;;; Execute tests in series (in one thread) +;;; tests : list-of (test-proc base-path makefile-base-name) +;;; +(define (execute-tests tests) + (let ((test-count (length tests)) + (pass-count + (fold (lambda (test cnt) + (let-values (((pass out) (execute-test test))) + (println out) + (+ cnt (if pass 1 0)))) + 0 tests))) + (printf "PASSED ~a/~a\n\n" pass-count test-count))) + +;;; +;;; Execute tests in parallel +;;; tests : list-of (test-proc base-path makefile-base-name) +;;; +(define (execute-tests-parallel tests max-threads-count) + (let ((test-count (length tests))) + (let loop ((tests tests) + (threads '()) + (pass-count 0)) + + (if (and (null? tests) + (null? threads)) + ;; Done + (printf "PASSED ~a/~a\n\n" pass-count test-count) + + ;; Not all tests complete + (let ((threads-prev threads)) + ;; Run new thread if thread pool is not full + (let-values + (((tests threads) + (if (and (< (length threads) max-threads-count) + (not (null? tests))) + (let* ((test (car tests)) + (thd + (call-with-new-thread + (lambda () + (execute-test test))))) + (values (cdr tests) (cons thd threads))) + (values tests threads)))) + + ;; Get exited threads + (let* ((trest.passc + (fold + (lambda (thd t.p) + (let ((trest (car t.p)) + (passc (cdr t.p))) + (if (thread-exited? thd) + (let-values (((pass out) (join-thread thd))) + (println out) + (cons trest (+ passc (if pass 1 0)))) + (cons (cons thd trest) passc)))) + (cons '() pass-count) threads)) + + (threads (car trest.passc)) + (pass-count (cdr trest.passc))) + + ;; Sleep when no new threads and no exited threads + (when (= (length threads-prev) + (length threads)) + (usleep 10000) + (yield)) + + ;; Loop + (loop tests threads pass-count)))))))) + +;;; +;;; Test item macro +;;; +(define-syntax utest/tb + (syntax-rules () + ((_ (n d ...) body ...) + (lambda id + (cond + ((null? id) (begin body ...)) + ((eq? (car id) 'name) n) + ((eq? (car id) 'description) + ((lambda rest + (if (null? rest) + #f + (string-append + (car rest) + (apply string-append + (map (lambda (x) (string-append "\n" x)) + (cdr rest)))))) + d ...)) + (else #f)))) + + ((_ () body ...) + (utest/tb (#f) body ...)))) + +;;; +;;; Delete working folders +;;; +(define (delete-work-dirs base force) + (let ((work-dirs + (if force + (find-paths + (lambda (p t) + (and (eq? t 'directory) + (string-match + (format "^~a.*-[0-9]{10}-.{6}$" WORK_DIR_PREFIX) + (basename p)))) + base) + (fold + (lambda (makefile work-dirs) + (append + work-dirs + (find-paths + (lambda (p t) + (and (eq? t 'directory) + (string-match + (format "^~a~a.*-[0-9]{10}-.{6}$" WORK_DIR_PREFIX (basename makefile)) + (basename p)))) + (dirname makefile)))) + '() (find-files-regexp MAKEFILE_NAME_REGEXP base))))) + (if (null? work-dirs) + (printf "Working folders not found\n") + (for-each + (lambda (dir) + (printf "Delete \"~a\"\n" dir) + (delete-recursive dir)) + work-dirs)))) + +;;; +;;; Print log level verilog defines +;;; +(define (print-verilog-defines) + (define (* . fmt) (apply printf fmt) (newline)) + (* "`ifndef UTEST_VERILOG_DEFINES") + (* " `define UTEST_VERILOG_DEFINES") + (* "") + (* "// Log level string prefixes for use with $display function.") + (* "// Example usage: $display(\"%sError message\", `LOG_ERR);") + (* " `define LOG_INFO \"~a\"" LOG_PREFIX_INFO) + (* " `define LOG_WARN \"~a\"" LOG_PREFIX_WARN) + (* " `define LOG_ERR \"~a\"" LOG_PREFIX_FAIL) + (* "") + (* "// Dirty hacked redefine of $display function. Must be used with two parentheses.") + (* "// Example usage: `log_info((\"Information message\"));") + (* " `define log_info(msg) begin $display({`LOG_INFO, $sformatf msg}); end") + (* " `define log_warn(msg) begin $display({`LOG_WARN, $sformatf msg}); end") + (* " `define log_error(msg) begin $display({`LOG_ERR, $sformatf msg}); end") + (* "`endif")) + +;;; +;;; Print help +;;; +(define (print-help app-name) + (define (* . fmt) (apply printf fmt) (newline)) + (* "Usage: ~a [OPTION]... [FILE|PATH]" app-name) + (* "Run testbenches with recursive search in the PATH, or in the current folder") + (* "if PATH is not specified. If argument is a file, testbench is launched from FILE.") + (* "") + (* "Options:") + (* " -k, --keep Do not delete work directory if test is pass.") + (* " -d, --dump Force dump waveforms.") + (* " -r, --no-restart Do not restart testbench with waveform dump enabled if") + (* " test failed (true by default)") + (* " -n, --nocolor Do not use color for print log") + (* " -j, --jobs NUM Use NUM threads for running testbenches. If <=0") + (* " use as many threads as there are processors in the system.") + (* " -f, --defines Print useful Verilog defines") + (* " -c, --clean Delete work folders that have a corresponding makefile.") + (* " --force-clean Delete all work folders regardless of the presence of a makefile.") + (* " -v, --verbose Verbose output") + (* " -V, --version Print version") + (* " -h, --help Print this message and exit") + (* "") + (* "Source code and issue tracker: ")) + +;;; +;;; Print app version, legals and copyright +;;; +(define (print-version) + (define (* . fmt) (apply printf fmt) (newline)) + (* "utest ~a" APP_VERSION)) + +;;; +;;; Main +;;; +(let ((args (command-line))) + (let* ((optspec `((keep (single-char #\k)) + (dump (single-char #\d) (value #f)) + (no-restart (single-char #\r) (value #f)) + (nocolor (single-char #\n) (value #f)) + (verbose (single-char #\v) (value #f)) + (jobs (single-char #\j) (value #t) (predicate ,string->number)) + (help (single-char #\h) (value #f)) + (version (single-char #\V) (value #f)) + (clean (single-char #\c) (value #f)) + (force-clean (value #f)) + (defines (single-char #\f) (value #f)))) + + (options (getopt-long args optspec)) + (jobs (string->number (option-ref options 'jobs "0"))) + (jobs (if (zero? jobs) (current-processor-count) jobs)) + (rest (option-ref options '() '())) + (path (canonicalize-path (if (null? rest) (getcwd) (car rest))))) + + (cond + ((option-ref options 'help #f) (print-help (car args))) + ((option-ref options 'version #f) (print-version)) + ((option-ref options 'defines #f) (print-verilog-defines)) + ((option-ref options 'clean #f) (delete-work-dirs path #f)) + ((option-ref options 'force-clean #f) (delete-work-dirs path #t)) + + (else + (utest/keep-output (option-ref options 'keep #f)) + (utest/force-dump (option-ref options 'dump #f)) + (utest/restart-dump (not (option-ref options 'no-restart #f))) + (utest/nocolor (option-ref options 'nocolor #f)) + (utest/verbose (option-ref options 'verbose #f)) + + (let ((makefiles + (if (eq? 'regular (stat:type (stat path))) + (list path) + (find-files-regexp MAKEFILE_NAME_REGEXP path)))) + + (if (<= jobs 1) + (execute-tests (collect-test-procs makefiles)) + (execute-tests-parallel (collect-test-procs makefiles) jobs)))))))