GTKWave transaction filter example

axi-transaction-filter.scm

#!/usr/bin/env guile
!#

;; -*- geiser-scheme-implementation: guile -*-

(import (ice-9 textual-ports)           ; read port by lines
        (srfi srfi-1)                   ; lists
        (srfi srfi-11)                  ; let-values
        (srfi srfi-13)                  ; strings
        (srfi srfi-26)                  ; cut
        (srfi srfi-28)                  ; simple format
        (srfi srfi-43))                 ; vectors

;;;
;;; Formatted print with newline
;;;
(define (println fmt . args)
  (display (apply format (cons fmt args)))
  (newline))

;;;
;;; Insert x between list items
;;;
(define (insert-between lst x)
  (if (or (null? lst)
          (null? (cdr lst)))
      lst
      (cons* (car lst) x
             (insert-between (cdr lst) x))))

;;;
;;; Convert VCD binary to scheme vector
;;; See Table 21-9 of IEEE Std 1800-2012
;;;
;;; Characters will be replaced with numbers 1, 0 and symbols 'x and 'z
;;;
(define (vcd-bin-list->logic w l)
  (list->vector
   (map (lambda (c) (cond
                ((char=? c #\0) 0)
                ((char=? c #\1) 1)
                ((char-ci=? c #\x) 'x)
                ((char-ci=? c #\z) 'z)
                (else #f)))
        (take (if (>= (length l) w)
                  l
                  (let ((msb (last l)))
                    (append
                     l
                     (make-list (- w (length l))
                                (if (char=? #\1 msb)
                                    #\0
                                    msb)))))
              w))))

;;;
;;; Convert bit vector to number
;;; Function returns number or #f if the vector contains 'x or 'z
;;;
(define* (logic->number v #:key (x-replace 'x) (z-replace 'z))
  (let ((v (vector-map (lambda (i bit) (cond
                                   ((eq? bit 'x) x-replace)
                                   ((eq? bit 'z) z-replace)
                                   (else bit)))
                       v)))
    (and (vector-every number? v)
         (vector-fold (lambda (i sum bit) (+ sum (* bit (expt 2 i)))) 0 v))))

;;;
;;; Convert bit vector to hex string
;;;
(define (logic->hex v)
  (let logic-list->hex ((l (vector->list v)))
    (let ((nibble
           (fold (lambda (bit exp sum)
                   (cond
                    ((not (number? bit)) bit)
                    ((not (number? sum)) sum)
                    (else (+ sum (* bit exp)))))
                 0 l '(1 2 4 8))))
      (let ((nibble-str
             (if (number? nibble)
                 (string (string-ref "0123456789abcdef" nibble))
                 (symbol->string nibble))))
        (if (<= (length l) 4)
            nibble-str
            (string-append (logic-list->hex (drop l 4))
                           nibble-str))))))

;;;
;;; Convert bit vector to binary string
;;;
(define (logic->bin v)
  (list->string
   (reverse
    (map (lambda (x)
           (if (number? x)
               (if (zero? x) #\0 #\1)
               (if (eq? x 'x) #\x #\z)))
         (vector->list v)))))

;;;
;;; Convert number to logic
;;;
(define (number->logic width x)
  (vcd-bin-list->logic
   width
   (reverse
    (let ((bin (string->list (number->string x 2))))
      (if (>= (length bin) width)
          (take bin width)
          bin)))))

;;; Returns #t if all bits of vector is 0
(define (logic-zero? v)
  (vector-every (cut eq? 0 <>) v))

;;; Returns #t if all bits of vector is 1
(define (logic-one? v)
  (vector-every (cut eq? 1 <>) v))

;;; Returns #t if any bit of vector is 'x
(define (logic-have-x? v)
  (vector-any (cut eq? 'x <>) v))

;;; Returns #t if any bit of vector is 'z
(define (logic-have-z? v)
  (vector-any (cut eq? 'z <>) v))

;;; Returns #t if all bits of vector is 0 or 1
(define (logic-valid? v)
  (vector-every number? v))

;;; Concatenate logic vectors
(define (logic-concat . args)
  (vector-concatenate args))

;;;
;;; Parse timescale value (1ps, 100ns, etc)
;;;
(define (parse-timescale ts)
  (let ((dim-idx (string-skip ts char-numeric?)))
    (if dim-idx
        (let* ((n (string->number (substring ts 0 dim-idx)))
               (unit (substring ts dim-idx))
               (k (assoc unit '(("s" 1) ("ms" 1e-3) ("us" 1e-6) ("ns" 1e-9) ("ps" 1e-12) (fs 1e-15)))))
          (if k
              (* n (cadr k))
              (raise `(vcd-syntax-error
                       ,(format "Unknown timescale unit '~a'" unit)))))
        (raise `(vcd-syntax-error
                 ,(format "Wrong timescale '~a'" ts))))))

;; (define get-line-old get-line)
;; (define (get-line port)
;;   (let ((l (get-line-old port)))
;;     (display l (current-error-port))
;;     (newline (current-error-port))
;;     l))

;;;
;;; Parse VCD header (definitions)
;;; Returns header data:
;;; '(<bundle-name>
;;;   <timescale>
;;;   <min-time>
;;;   <max-time>
;;;   ;; signals info
;;;   (<vcd-id> <full-name> <width> <slice>)
;;;   (<vcd-id> <full-name> <width> <slice>)
;;;   ...)
;;;
;;; <timescale> - timescale multiplier (e.g. for 10ns timescale value is 1e-8)
;;; <vcd-id>    - VCD identifier string
;;; <full-name> - signal name with scope (e.g. mod1.get0.sig)
;;; <slice>     - signal dimension string (e.g. "[31:0]")
;;;
;;; If EOF, return #f
;;;
(define* (parse-vcd-header #:optional (port (current-input-port)))
  (let ((name "")
        (timescale 1e-12)
        (min-time 0)
        (max-time 0)
        (scope '())
        (signals '()))
    (let next-line ()
      (let ((s (get-line port)))
        (cond
         ;; End of file. Return false
         ((eof-object? s) #f)

         ;; Bundle name
         ((string-prefix? "$comment name" s)
          (set! name (string-trim-both
                      (substring s 13 (- (string-length s)
                                         (if (string-suffix? " $end" s) 4 0)))))
          (next-line))

         ;; Min_time
         ((string-prefix? "$comment min_time" s)
          (set! min-time (string->number (third (string-split s #\space))))
          (next-line))

         ;; Max_time
         ((string-prefix? "$comment max_time" s)
          (set! max-time (string->number (third (string-split s #\space))))
          (next-line))

         ;; Timescale
         ((string-prefix? "$timescale" s)
          (set! timescale (parse-timescale (second (string-split s #\space))))
          (next-line))

         ;; Scope (ignore scope type)
         ((string-prefix? "$scope" s)
          (set! scope (cons (third (string-split s #\space)) scope))
          (next-line))

         ;; Upscope
         ((string-prefix? "$upscope" s)
          (set! scope (cdr scope))
          (next-line))

         ;; Signal description
         ((string-prefix? "$var" s)
          (set! signals
                (let ((si (string-split s #\space)))
                  (cons
                   `( ;; id
                     ,(fourth si)
                     ;; name
                     ,(string-concatenate
                       (reverse
                        (insert-between
                         (cons (first (string-split (fifth si) #\[)) scope)
                         ".")))
                     ;; width
                     ,(string->number (third si))
                     ;; slice
                     ,(let ((ni (cdr (string-split (fifth si) #\[))))
                        (if (null? ni)
                            ""
                            (string-append "[" (car ni)))))
                   signals)))
          (next-line))

         ;; Done
         ((string-prefix? "$enddefinitions" s)
          `(,name
            ,timescale
            ,min-time
            ,max-time
            ,@(sort signals
                    (lambda (s1 s2)
                      (string<? (car s1)
                                (car s2))))))

         ;; Skip line
         (else (next-line)))))))

;;;
;;; Parse VCD body
;;; Returns VCD changes as samples list:
;;; '((<time> (<vcd-id> <lsb> ... <msb>) (<id> <lsb> ... <msb>) ...)
;;;   (<time> (<vcd-id> <lsb> ... <msb>) (<id> <lsb> ... <msb>) ...)
;;;   ...
;;; )
;;;
;;; If EOF, return #f
;;;
(define* (parse-vcd-body #:optional (port (current-input-port)))
  (let next-line ((time #f)
                  (sample '())
                  (signals '()))
    (let ((s (get-line port)))
      (cond
       ;; End of file. Return false
       ((eof-object? s) #f)

       ;; Empty line
       ((string-null? s) (next-line time sample signals))

       ;; End of VCD data
       ((string-prefix? "$comment data_end" s)
        (reverse
         (if (and time (not (null? sample)))
             ;; Add last sample
             (cons (cons time sample) signals)
             signals)))

       ;; Time stamp
       ((char=? #\# (string-ref s 0))
        (next-line (string->number (substring s 1))
                   '()
                   (if (and time (not (null? sample)))
                       (cons (cons time sample) signals)
                       signals)))

       ;; Scalar
       ((let ((c (string-ref s 0)))
          (or (char-ci=? c #\0)
              (char-ci=? c #\1)
              (char-ci=? c #\x)
              (char-ci=? c #\z)))
        (next-line time
                   (cons `(,(substring s 1)
                           ,(char-downcase
                             (string-ref s 0)))
                         sample)
                   signals))

       ;; Vector
       ((char=? #\b (string-ref s 0))
        (let ((si (string-split s #\space)))
          (next-line time
                     (cons (cons
                            (second si)
                            (reverse
                             (string->list
                              (string-downcase
                               (substring (first si) 1)))))
                           sample)
                     signals)))

       ;; TODO: Parse real?

       ;; Skip line
       (else (next-line time sample signals))))))

;;;
;;; VCD header data accessors
;;;
(define vcd-name first)
(define vcd-timescale second)
(define vcd-min-time third)
(define vcd-max-time fourth)
(define vcd-signals cddddr)
(define (vcd-info vcd-header)
  (take vcd-header 4))

;;; VCD header signals accessors
(define vcd-signal-id first)
(define vcd-signal-full-name second)
(define vcd-signal-width third)
(define vcd-signal-dim fourth)
(define (vcd-signal-name signal)
  (last (string-split (vcd-signal-full-name signal) #\.)))

;;; Return signal by VCD identifier
(define (vcd-signal-by-id id vcd-header)
  (assoc id (vcd-signals vcd-header)))

;;; Return signal by name predicate
(define* (vcd-signal-by-name-pred name-pred vcd-header #:key (with-scope #f))
  (let ((get-name (if with-scope vcd-signal-full-name vcd-signal-name)))
    (find (lambda (s) (name-pred (get-name s)))
          (vcd-signals vcd-header))))

;;; Return signal by name (exactly)
(define* (vcd-signal-by-name name vcd-header #:key (with-scope #f) (ci #f))
  (vcd-signal-by-name-pred
   (cut (if ci string-ci= string=?) name <>)
   vcd-header #:with-scope with-scope))

;;; Return signal ID by name (exactly)
(define* (vcd-signal-id-by-name name vcd-header #:key (with-scope #f) (ci #f))
  (let ((sig (vcd-signal-by-name name vcd-header #:with-scope with-scope #:ci ci)))
    (and sig (vcd-signal-id sig))))

;;; Return signal by name prefix
(define* (vcd-signal-by-prefix prefix vcd-header #:key (with-scope #f) (ci #f))
  (vcd-signal-by-name-pred
   (cut (if ci string-prefix-ci? string-prefix?) prefix <>)
   vcd-header #:with-scope with-scope))

;;; Return signal ID by name prefix
(define* (vcd-signal-id-by-prefix prefix vcd-header #:key (with-scope #f) (ci #f))
  (let ((sig (vcd-signal-by-prefix prefix vcd-header #:with-scope with-scope #:ci ci)))
    (and sig (vcd-signal-id sig))))

;;; Return signal by name suffix
(define* (vcd-signal-by-suffix suffix vcd-header #:key (with-scope #f) (ci #f))
  (vcd-signal-by-name-pred
   (cut (if ci string-suffix-ci? string-suffix?) suffix <>)
   vcd-header #:with-scope with-scope))

;;; Return signal ID by name suffix
(define* (vcd-signal-id-by-suffix suffix vcd-header #:key (with-scope #f) (ci #f))
  (let ((sig (vcd-signal-by-suffix suffix vcd-header #:with-scope with-scope #:ci ci)))
    (and sig (vcd-signal-id sig))))

;;; Filter signals
(define (vcd-signals-filter pred vcd-header)
  (filter pred (vcd-signals vcd-header)))

;;;
;;; Parse simplified VCD
;;; Returns:
;;; (values ;; header
;;;         '(<bundle-name>
;;;           <timescale>
;;;           <min-time>
;;;           <max-time>
;;;           (<id> <full-name> <width> <slice>)
;;;           (<id> <full-name> <width> <slice>)
;;;           ...)
;;;         ;; samples
;;;         '((<timestamp> (<id> . <bit-vector>) (<id> . <bit-vector>) ...)
;;;           (<timestamp> (<id> . <bit-vector>) (<id> . <bit-vector>) ...)
;;;           ...))
;;;
;;; <timescale>  - Timescale multiplier (e.g. 1e-8 for 10ns timescale)
;;; <id>         - Signal identifier number (note: it's not a VCD id)
;;; <full-name>  - Signal name with scope (e.g. mod1.get0.sig)
;;; <width>      - Signal width
;;; <slice>      - Signal dimension string (e.g. "[31:0]")
;;; <header>     - List returned by (parse-vcd-header)
;;; <name>       - Signal name string
;;; <bit-vector> - Vector of bits. Logic 'one' and 'zero' represented as numbers 1 and 0.
;;;                Logic 'X' and 'Z' states represented as symbols 'x and 'z.
;;; <timestamp>  - Sample time (number)
;;;
(define* (parse-vcd #:optional (port (current-input-port)))
  (let* ((header (parse-vcd-header port))
         (samples (parse-vcd-body port)))
    (if (and header samples)
        ;; Make VCD data
        (let* ((signals (vcd-signals header))
               (sample-widths (map vcd-signal-width signals))
               (sample-vcd-ids (map vcd-signal-id signals))
               (sample-ids (iota (length signals))))
          (values
           (append (vcd-info header)
                   (map (lambda (s id) (cons id (cdr s)))
                        (vcd-signals header)
                        sample-ids))
           ;; Loop for samples
           (let next ((samples samples)
                      (result '())
                      (last-sample (map (const #\x) signals)))
             (if (null? samples)
                 (reverse result)
                 (let* ((sample (car samples))
                        (time (car sample))
                        (changes (cdr sample))
                        (new-sample
                         (map (lambda (s w id)
                                (let ((new (assoc id changes)))
                                  (if new
                                      (vcd-bin-list->logic w (cdr new))
                                      s)))
                              last-sample
                              sample-widths
                              sample-vcd-ids)))
                   (next (cdr samples)
                         (cons (cons time (map cons sample-ids new-sample)) result)
                         new-sample))))))

        ;; Return #f when eof reached
        (values #f #f))))

;;;
;;; Sample accessors
;;;
(define sample-time first)
(define sample-signals cdr)
(define (sample-value signal-id sample)
  (cdr (assoc signal-id (sample-signals sample))))

;;; --------------------------- END OF COMMON CODE -----------------------------

;;; Background color of events
;;; Colors list: https://github.com/gtkwave/gtkwave/blob/master/src/rgb.c#L34
(define event-colors
  '((error "dark red")
    (warn "dark orange")))

(define* (event time text #:optional (type 'none))
  `(,time ,type ,text))

(define* (event->vcd ev)
  (format "#~a ~a~a"
          (first ev)
          (let ((color (assq (second ev) event-colors)))
            (if color
                (format "?~a?" (second color))
                ""))
          (third ev)))

(define (make-bus-axi vcd-header)
  (let* ((signal-syms
          '( ;; Write address
            awid awaddr awlen awsize awburst awlock awcache awprot awqos awvalid awready
            ;; Write data
            wid wdata wstrb wlast wvalid wready
            ;; Write response
            bid bresp bvalid output bready
            ;; Read address
            arid araddr arlen arsize arburst arlock arcache arprot arqos arvalid arready
            ;; Read data
            rid rdata rresp rlast rvalid rready))
         (ids (map (lambda (signal-sym)
                     (cons signal-sym
                           (vcd-signal-id-by-suffix
                            (symbol->string signal-sym)
                            vcd-header)))
                   signal-syms)))
    (lambda (sig-sym)
      (let ((symid (assq sig-sym ids)))
        (and symid (cdr symid))))))

(define (make-bus-accessor bus signals)
  (let ((ids (map bus signals)))
    (lambda (sample)
      (apply values
             (map (cut sample-value <> sample) ids)))))

(define (extract-axi-ar-channel header samples)
  (let* ((axi (make-bus-axi header))
         (t0 (vcd-min-time header))
         (ar-siglist '(arvalid arready araddr arlen))
         (ar-signals (make-bus-accessor axi ar-siglist)))
    (if (not (every axi ar-siglist))
        ;; Missing signals
        `(,(event t0 "BUS INCOMPLETE" 'error))
        ;; Decode bus state
        (let next ((samples samples)
                   (events '()))
          (if (null? samples)
              (reverse events)
              (let* ((sample (car samples))
                     (time (sample-time sample))
                     (rest-samples (cdr samples)))
                (let-values (((arvalid arready araddr arlen)
                              (ar-signals sample)))
                  (cond
                   ;; New address
                   ((and (logic-one? arvalid)
                         (logic-one? arready))
                    (next rest-samples
                          (cons
                           (if (and (logic-valid? araddr)
                                    (logic-valid? arlen))
                               ;; Valid address
                               (event time (logic->hex araddr))
                               ;; Invalid address
                               (event time "BAD ADDR" 'error))
                           events)))

                   ;; Unknown bus state (arvalid=1, arready=x)
                   ((and (logic-one? arvalid)
                         (not (logic-valid? arready)))
                    (next rest-samples
                          (cons (event time "ARREADY INVALID" 'warn)
                                events)))

                   ;; Prepare address (arvalid=1, arready=0)
                   ((logic-one? arvalid)
                    (next rest-samples (cons (event time "") events)))

                   ;; TODO: Add bus states
                   (else (next rest-samples events))))))))))





;;; Main
(let-values (((header samples)
              (parse-vcd)))
  (when (and header samples)
    (let ((events (extract-axi-ar-channel header samples)))
      (println "$name READ ADDR")
      (for-each (lambda (event) (println "~a" (event->vcd event))) events)
      (println "$finish"))))