np/embddr-scheme-library
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Reduce memory consumption. Complete samples to last time stamp

Browse Source
This commit is contained in:
Nikolay Puzanov 2022-12-07 12:13:15 +03:00
parent 1ac868314b
commit 4d27f16630
1 changed files with 145 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

274
embddr/vcd.scm
View File

@ -12,6 +12,9 @@
(import (embddr common)) (import (embddr common))
(export vcd-parse (export vcd-parse
vcd-timescale
vcd-timestamps
vcd-signals
(signal-scope . vcd-signal-scope) (signal-scope . vcd-signal-scope)
(signal-name . vcd-signal-name) (signal-name . vcd-signal-name)
(signal-type . vcd-signal-type) (signal-type . vcd-signal-type)
@ -26,7 +29,7 @@
(vcd-new timescale timestamps signals) (vcd-new timescale timestamps signals)
vcd? vcd?
(timescale vcd-timescale) (timescale vcd-timescale)
(timestamps vcd-tstamps) (timestamps vcd-timestamps)
(signals vcd-signals)) (signals vcd-signals))
;;; ;;;
@ -170,118 +173,127 @@
(else (next-cmd timescale scope tags+signals)))))))) (else (next-cmd timescale scope tags+signals))))))))
;;; ;;;
;;; Read data block and return list of lists (time changes ..) ;;; Read data changes sample and return list of (time changes ...)
;;; ;;;
(define (read-data port) (define (read-sample port)
(let read-rec ((samples '()) (let read-rec ((time #f) (changes '()))
(time #f)
(changes '()))
(let ((line (get-line port))) (let ((line (get-line port)))
(if (eof-object? line) (if (eof-object? line)
(reverse (if time (cons time changes) #f)
(if (and time (not (null? changes)))
(cons (cons time changes) samples)
samples))
(let ((line (string-trim-both line))) (let ((line (string-trim-both line)))
(cond (cond
((or (string-null? line) ((or (string-null? line)
(equal? (string-ref line 0) #\$)) ;; (equal? (string-ref line 0) #\$)
(read-rec samples time changes)) (not
(let ((c (string-ref line 0)))
(or (eq? c #\0)
(eq? c #\1)
(eq? c #\x)
(eq? c #\X)
(eq? c #\z)
(eq? c #\Z)
(eq? c #\b)
(eq? c #\r)
(eq? c #\#)))))
(read-rec time changes))
((equal? (string-ref line 0) #\#) ((equal? (string-ref line 0) #\#)
(read-rec (if time
(if (and time (not (null? changes))) (begin
(cons (cons time changes) samples) (unget-string port (format "~a\n" line))
samples) (cons time changes))
(let ((time (string->number (substring line 1)))) (let ((time (string->number (substring line 1))))
(if time (if time
time (read-rec time '())
(raise `(vcd-syntsx-error "Bad time format '~a'" line)))) (raise `(vcd-syntsx-error "Bad time format '~a'" line))))))
'()))
(else (else
(read-rec samples time (cons line changes))))))))) (read-rec time (cons line changes)))))))))
;;; ;;;
;;; Parse VCD data block ;;; Read and parse VCD data block
;;; Returns <vcd> record ;;; Returns <vcd> record
;;; ;;;
(define (parse-data samples timescale tags+signals) (define (read-data port timescale tags+signals)
(let* ((samples-count (length samples)) (let* ((tags+signals-ht (alist->hash-table tags+signals))
(tags+signals-ht (alist->hash-table tags+signals))) (timestamps
(let loop ((timestamps '()))
(for-each (let ((sample (read-sample port)))
(lambda (sample) (if sample
(let ((time (car sample))) (let ((time (car sample)))
(for-each
(lambda (line)
(let ((c0 (string-ref line 0))
(rest (substring line 1)))
;; (display (format "-- c0:'~a' rest:'~a'\n" c0 rest))
(let-values
(((parse-value tag value)
(cond
;; Scalar value
((or (equal? c0 #\0)
(equal? c0 #\1)
(char-ci=? c0 #\x)
(char-ci=? c0 #\z))
(values parse-binary-value
rest
(string (char-downcase c0))))
;; Binary or real value
((or (char-ci=? c0 #\b)
(char-ci=? c0 #\r))
;; Fast but unsafe
(let ((val-idx (string-index rest #\space)))
(if val-idx
(let ((value (substring rest 0 val-idx))
(tag (substring rest (+ val-idx 1))))
(values (if (char-ci=? c0 #\b)
parse-binary-value
parse-real-value)
tag
value))
(raise `(vcd-syntax-error
,(format "Bad value change string '~a'" line)))))
;; Slow but safety
;; (let ((ss (string-split-trim rest char-whitespace?)))
;; (if (= (length ss) 2)
;; (let ((value (first ss))
;; (tag (second ss)))
;; (values (if (char-ci=? c0 #\b)
;; parse-binary-value
;; parse-real-value)
;; tag
;; value))
;; (raise `(vcd-syntax-error
;; ,(format "Bad value change string '~a'" line)))))
))))
(let ((sigs (hash-table-ref/default tags+signals-ht tag #f)))
(unless (null? sigs)
(for-each (for-each
(lambda (sig) (lambda (line)
(signal-add! (let ((c0 (string-ref line 0))
sig (rest (substring line 1)))
(cons time (parse-value value (signal-size sig))))) (let-values
sigs)))))) (((parse-value tag value)
(cdr sample)))) (cond
samples) ;; Scalar value
((or (equal? c0 #\0)
(equal? c0 #\1)
(char-ci=? c0 #\x)
(char-ci=? c0 #\z))
(values parse-binary-value
rest
(string (char-downcase c0))))
(vcd-new timescale ;; Binary or real value
(map car samples) ((or (char-ci=? c0 #\b)
(let ((signals (fold (lambda (tag+sig out) (char-ci=? c0 #\r))
(append (cdr tag+sig) out))
'() tags+signals)) ;; Fast but unsafe
(last-time (car (last samples)))) ;; Does not remove leading and trailing spaces
(map (lambda (sig) ;; and spaces between value and tag
(signal-set! sig (reverse (signal-get sig))) (let ((val-idx (string-index rest #\space)))
sig) (if val-idx
signals))))) (let ((value (substring rest 0 val-idx))
(tag (substring rest (+ val-idx 1))))
(values (if (char-ci=? c0 #\b)
parse-binary-value
parse-real-value)
tag
value))
(raise `(vcd-syntax-error
,(format "Bad value change string '~a'" line)))))))))
;; Update register values list
(let ((sigs (hash-table-ref/default tags+signals-ht tag #f)))
(unless (null? sigs)
(for-each
(lambda (sig)
(signal-add!
sig
(cons time (parse-value value (signal-size sig)))))
sigs))))))
(cdr sample))
(loop (cons time timestamps)))
timestamps)))))
(let ((signals (fold (lambda (tag+sig out)
(append (cdr tag+sig) out))
'() tags+signals)))
(if (null? timestamps)
(vcd-new timescale timestamps signals)
(vcd-new timescale
(reverse timestamps)
;; Complete values to last time stamp
(let ((last-time (car timestamps)))
(map (lambda (sig)
(signal-set!
sig
(reverse
(let ((values (signal-get sig)))
(if (null? values)
'()
(let ((last-val (car values)))
(if (= last-time (car last-val))
values
(cons (cons last-time
(cdr last-val))
values)))))))
sig)
signals)))))))
;;; ;;;
;;; Parse whole VCD ;;; Parse whole VCD
@ -290,39 +302,43 @@
(define (vcd-parse port) (define (vcd-parse port)
(call-with-values (call-with-values
(lambda () (read-header port)) (lambda () (read-header port))
(cut parse-data (cut read-data port <...>)))
(read-data port)
<...>)))
;;; ;;;
;;; Convert 4-state binary string to hex ;;; Convert 4-state binary string to hex
;;; ;;;
(define (vcd-binary->hex binstr) (define* (vcd-binary->hex binstr #:optional (trim #f))
(string-concatenate (let ((hex
(map (string-concatenate
(lambda (quad) (map
(if (string-every char-numeric? quad) (lambda (quad)
(number->string (if (string-every char-numeric? quad)
(string->number quad 2) (number->string
16) (string->number quad 2)
(if (string-every (cut char-ci=? #\z <>) quad) 16)
"z" (if (string-every (cut char-ci=? #\z <>) quad)
"x"))) "z"
(let split-by-quad ((str (string-reverse binstr)) "x")))
(quads '())) (let split-by-quad ((str (string-reverse binstr))
(cond (quads '()))
((string-null? str) quads) (cond
((<= (string-length str) 4) ((string-null? str) quads)
(cons (string-append ((<= (string-length str) 4)
(make-string (cons (string-append
(- 4 (string-length str)) (make-string
(let ((h (string-ref str 0))) (- 4 (string-length str))
(if (char-numeric? h) #\0 h))) (let ((h (string-ref str 0)))
(string-reverse str)) (if (char-numeric? h) #\0 h)))
quads)) (string-reverse str))
(else quads))
(split-by-quad (else
(string-drop str 4) (split-by-quad
(cons (string-drop str 4)
(string-reverse (cons
(string-take str 4)) quads)))))))) (string-reverse
(string-take str 4)) quads)))))))))
(if trim
(if (eq? (string-ref hex (- (string-length hex) 1)) #\0)
"0"
(string-append (string-trim hex #\0)))
hex)))