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

128
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,54 +173,58 @@
(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 (for-each
(lambda (line) (lambda (line)
(let ((c0 (string-ref line 0)) (let ((c0 (string-ref line 0))
(rest (substring line 1))) (rest (substring line 1)))
;; (display (format "-- c0:'~a' rest:'~a'\n" c0 rest))
(let-values (let-values
(((parse-value tag value) (((parse-value tag value)
(cond (cond
@ -235,6 +242,8 @@
(char-ci=? c0 #\r)) (char-ci=? c0 #\r))
;; Fast but unsafe ;; Fast but unsafe
;; Does not remove leading and trailing spaces
;; and spaces between value and tag
(let ((val-idx (string-index rest #\space))) (let ((val-idx (string-index rest #\space)))
(if val-idx (if val-idx
(let ((value (substring rest 0 val-idx)) (let ((value (substring rest 0 val-idx))
@ -245,22 +254,9 @@
tag tag
value)) value))
(raise `(vcd-syntax-error (raise `(vcd-syntax-error
,(format "Bad value change string '~a'" line))))) ,(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)))))
))))
;; Update register values list
(let ((sigs (hash-table-ref/default tags+signals-ht tag #f))) (let ((sigs (hash-table-ref/default tags+signals-ht tag #f)))
(unless (null? sigs) (unless (null? sigs)
(for-each (for-each
@ -269,19 +265,35 @@
sig sig
(cons time (parse-value value (signal-size sig))))) (cons time (parse-value value (signal-size sig)))))
sigs)))))) sigs))))))
(cdr sample)))) (cdr sample))
samples)
(loop (cons time timestamps)))
timestamps)))))
(vcd-new timescale
(map car samples)
(let ((signals (fold (lambda (tag+sig out) (let ((signals (fold (lambda (tag+sig out)
(append (cdr tag+sig) out)) (append (cdr tag+sig) out))
'() tags+signals)) '() tags+signals)))
(last-time (car (last samples)))) (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) (map (lambda (sig)
(signal-set! sig (reverse (signal-get 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) sig)
signals))))) signals)))))))
;;; ;;;
;;; Parse whole VCD ;;; Parse whole VCD
@ -290,14 +302,13 @@
(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))
(let ((hex
(string-concatenate (string-concatenate
(map (map
(lambda (quad) (lambda (quad)
@ -325,4 +336,9 @@
(string-drop str 4) (string-drop str 4)
(cons (cons
(string-reverse (string-reverse
(string-take str 4)) quads)))))))) (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)))