ildb: skip route locks and signal names
parent
88d6d9e971
commit
cf5e76a2fc
|
@ -4,7 +4,6 @@
|
|||
(:export :load-ildb
|
||||
:ars-rule :ars-rule-p :ars-rule-type :ars-rule-match :ars-rule-invertp
|
||||
:tcbside :make-tcbside :tcbside-p :tcbside-pos :tcbside-side
|
||||
:path-entry :path-entry-p :path-entry-next :path-entry-locks
|
||||
:route :route-p :route-name :route-ars-rules :route-path
|
||||
:tcbdata :tcbdata-p :tcbdata-signal-pos :tcbdata-signal-name :tcbdata-routes
|
||||
:tcb :tcb-p :tcb-pos :tcb-side-a :tcb-side-b
|
||||
|
@ -47,30 +46,10 @@
|
|||
(with-accessors ((p tcbside-pos) (side tcbside-side)) obj
|
||||
(json:encode-json (list (cons "p" p) (cons "s" side)))))
|
||||
|
||||
(defstruct path-entry
|
||||
(next nil :type (or null tcbside))
|
||||
(locks (aux:adj-vector-of '(cons aux:v3d string)) :type (vector (cons aux:v3d string))))
|
||||
|
||||
(defmethod print-object ((obj path-entry) s)
|
||||
(with-accessors ((next path-entry-next) (locks path-entry-locks)) obj
|
||||
(print-unreadable-object (obj s)
|
||||
(format s "TO ~a" (or next "EOI"))
|
||||
(loop for (pos . st) across locks do
|
||||
(format s " ~_LOCKING ~a TO ~s" pos st)))))
|
||||
|
||||
(defmethod json:encode-json ((obj path-entry) &optional json:*json-output*)
|
||||
(with-accessors ((next path-entry-next) (locks path-entry-locks)) obj
|
||||
(json:encode-json-alist (list (cons "next" next)
|
||||
(cons "locks" (loop with ht = (make-hash-table)
|
||||
for i across locks
|
||||
for (pos . st) = i
|
||||
do (setf (gethash pos ht) st)
|
||||
finally (return ht)))))))
|
||||
|
||||
(defstruct route
|
||||
(name "" :type string)
|
||||
(ars-rules (aux:adj-vector-of 'ars-rule) :type (or (eql t) (vector ars-rule)))
|
||||
(path (aux:adj-vector-of 'path-entry) :type (vector path-entry)))
|
||||
(path (aux:adj-vector-of '(or tcbside null)) :type (vector (or tcbside null))))
|
||||
|
||||
(defmethod print-object ((obj route) s)
|
||||
(with-accessors ((name route-name) (ars route-ars-rules) (path route-path)) obj
|
||||
|
@ -92,27 +71,20 @@
|
|||
(defstruct tcbdata
|
||||
(ts nil :type (or string null))
|
||||
(signal-pos nil :type (or aux:v3d null))
|
||||
(signal-name nil :type (or string null))
|
||||
(routes (aux:adj-vector-of 'route) :type (vector route)))
|
||||
|
||||
(defmethod print-object ((obj tcbdata) s)
|
||||
(with-accessors ((ts tcbdata-ts) (spos tcbdata-signal-pos) (sname tcbdata-signal-name)
|
||||
(routelist tcbdata-routes))
|
||||
obj
|
||||
(with-accessors ((ts tcbdata-ts) (spos tcbdata-signal-pos) (routelist tcbdata-routes)) obj
|
||||
(print-unreadable-object (obj s)
|
||||
(format s "~:i~:[EOI~;~:*IN SECTION ~a~]~:[~*~; ~:_~:*SIGNALING AT ~a NAMED ~s~]"
|
||||
ts spos sname)
|
||||
(format s "~:i~:[EOI~;~:*IN SECTION ~a~]~@[ SIGNALING AT ~a~]" ts spos)
|
||||
(when (> (length routelist) 0)
|
||||
(pprint-indent :block 1 s)
|
||||
(loop for i across routelist do (format s " ~_~a" i))))))
|
||||
|
||||
(defmethod json:encode-json ((obj tcbdata) &optional json:*json-output*)
|
||||
(with-accessors ((ts tcbdata-ts) (spos tcbdata-signal-pos) (sname tcbdata-signal-name)
|
||||
(routelist tcbdata-routes))
|
||||
obj
|
||||
(with-accessors ((ts tcbdata-ts) (spos tcbdata-signal-pos) (routelist tcbdata-routes)) obj
|
||||
(json:encode-json (list (cons "in_section" ts)
|
||||
(cons "signal_pos" spos)
|
||||
(cons "signal_name" sname)
|
||||
(cons "routes" routelist)))))
|
||||
|
||||
(defstruct tcb
|
||||
|
@ -173,11 +145,11 @@
|
|||
finally (return ,r)))))
|
||||
|
||||
(defmacro route-next (route)
|
||||
(alexandria:with-gensyms (p)
|
||||
(alexandria:with-gensyms (p l)
|
||||
(alexandria:once-only
|
||||
(route)
|
||||
`(let ((,p (route-path ,route)))
|
||||
(path-entry-next (aref ,p (1- (length ,p))))))))
|
||||
`(let* ((,p (route-path ,route)) (,l (length ,p)))
|
||||
(if (> ,l 0) (aref ,p (1- ,l)))))))
|
||||
|
||||
(defmacro find-tcb-at (ildb pos)
|
||||
`(gethash ,pos (ildb-tcbs ,ildb)))
|
||||
|
@ -194,14 +166,12 @@
|
|||
finally (return ,locks))))
|
||||
|
||||
(defmacro parse-path (pathht)
|
||||
(alexandria:with-gensyms (ent next p s locks)
|
||||
`(aux:collect-integrally-indexed-non-nil
|
||||
((vector path-entry) ,pathht nil ,ent 1)
|
||||
(aux:with-entries-in-hash-table (,ent (,next "next") (,locks "locks"))
|
||||
(aux:with-entries-in-hash-table (,next (,p "p") (,s "s"))
|
||||
(make-path-entry :next (make-tcbside :pos (aux:hash-table-to-v3d ,p)
|
||||
:side (1- ,s))
|
||||
:locks (parse-route-locks ,locks)))))))
|
||||
(alexandria:with-gensyms (ent next p s)
|
||||
`(aux:collect-integrally-indexed-entries
|
||||
((vector (or tcbside null)) ,pathht nil ,ent 1)
|
||||
(let ((,next (gethash "next" ,ent)))
|
||||
(if ,next (aux:with-entries-in-hash-table (,next (,p "p") (,s "s"))
|
||||
(make-tcbside :pos (aux:hash-table-to-v3d ,p) :side (1- ,s))))))))
|
||||
|
||||
(defmacro parse-ars-rules (rulesht)
|
||||
(alexandria:with-gensyms (ent neg ln rc ftype match)
|
||||
|
@ -233,16 +203,14 @@
|
|||
(parse-route ,ent))))
|
||||
|
||||
(defmacro read-tcb-side (side)
|
||||
(alexandria:with-gensyms (ts spos sname routes)
|
||||
(alexandria:with-gensyms (ts spos routes)
|
||||
(alexandria:once-only
|
||||
(side)
|
||||
`(let ((,ts (gethash "ts_id" ,side nil))
|
||||
(,spos (ignore-errors (aux:hash-table-to-v3d (gethash "signal" ,side))))
|
||||
(,sname (gethash "signal_name" ,side))
|
||||
(,routes (read-routes (gethash "routes" ,side (make-hash-table)))))
|
||||
(make-tcbdata :ts ,ts
|
||||
:signal-pos ,spos
|
||||
:signal-name ,sname
|
||||
:routes ,routes)))))
|
||||
|
||||
(defun load-ildb (fn)
|
||||
|
|
Loading…
Reference in New Issue