From 0bdfb513b2284d91e09cccf29c54b9c746f5ad8a Mon Sep 17 00:00:00 2001 From: y5nw Date: Tue, 24 Aug 2021 15:08:04 +0200 Subject: [PATCH] minor optimizations; rename certain functions for profiling --- dataserver.lisp | 4 ++-- interlocking.lisp | 6 ++--- serialize-lib.lisp | 49 +++++++++++++++++++++++----------------- tracks/database.lisp | 53 +++++++++++++++++++++----------------------- tracks/package.lisp | 2 +- ywatds.asd | 2 +- 6 files changed, 61 insertions(+), 55 deletions(-) diff --git a/dataserver.lisp b/dataserver.lisp index 68f6023..76153c2 100644 --- a/dataserver.lisp +++ b/dataserver.lisp @@ -24,8 +24,8 @@ `(uiop:subpathname *world-path* (concatenate 'string "advtrains_" ,name))) (defun load-data () - (let* ((ildb (atil:import-data (savefilepath "interlocking.ls")))) - (multiple-value-bind (tdb tdbtemp) (tracks:import-data (savefilepath "ndb4.ls")) + (let* ((ildb (atil:load-ildb (savefilepath "interlocking.ls")))) + (multiple-value-bind (tdb tdbtemp) (tracks:load-trackdb (savefilepath "ndb4.ls")) (if *debugp* (setf *trackdb-temp* tdbtemp)) (psetf *ildb* ildb *trackdb* tdb))) (when *gcp* diff --git a/interlocking.lisp b/interlocking.lisp index ab64129..8b700cd 100644 --- a/interlocking.lisp +++ b/interlocking.lisp @@ -1,7 +1,7 @@ (defpackage :advtrains-interlocking (:use :cl) (:nicknames :atil) - (:export :import-data + (: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 @@ -245,8 +245,8 @@ :signal-name ,sname :routes ,routes))))) -(defun import-data (fn) - (atsl:with-data-from-file (ht fn :hash-table) +(defun load-ildb (fn) + (atsl:with-data-from-file (ht fn :hash-table :only "tcbs") (let ((tcbs (make-hash-table :test #'equalp))) (loop for poss being each hash-key of (gethash "tcbs" ht) diff --git a/serialize-lib.lisp b/serialize-lib.lisp index 16a33a6..dbaba08 100644 --- a/serialize-lib.lisp +++ b/serialize-lib.lisp @@ -30,48 +30,57 @@ (defmacro adjust-line (line) `(string-right-trim '(#\Return) ,line)) -(defmacro read-table-entry (line stream gett-f) +(defmacro read-table-entry (line stream gett-f &key only) (alexandria:with-gensyms (key value kv vt) `(cl-ppcre:register-groups-bind (,key ,value) ("^(.*[^&]):(.+)$" ,line) (let ((,kv (string-to-value ,key nil)) (,vt (string-to-value ,value t))) - (values ,kv (if (equal ,vt 'table) - (funcall ,gett-f ,stream) - ,vt)))))) + (if (and ,only (not (equal ,only ,kv))) + (values nil nil (if (equal ,vt 'table) (skip-table ,stream))) + (values t ,kv (if (equal ,vt 'table) (funcall ,gett-f ,stream) ,vt))))))) -(defmacro iterate-table-entries ((stream key val gett-f) &body body) - (alexandria:with-gensyms (line) +(defmacro iterate-table-entries ((stream key val gett-f &key only) &body body) + (alexandria:with-gensyms (line use-entry-p) (alexandria:once-only (stream) `(do ((,line (adjust-line (read-line ,stream nil)) (adjust-line (read-line ,stream nil)))) - ((or (null ,line) (equal ,line "E"))) - (multiple-value-bind (,key ,val) - (read-table-entry ,line ,stream ,gett-f) - ,@body))))) + ((or (null ,line) (string= ,line "E"))) + (multiple-value-bind (,use-entry-p ,key ,val) + (read-table-entry ,line ,stream ,gett-f :only ,only) + (when ,use-entry-p ,@body)))))) -(declaim (ftype (function (stream) list) read-table-as-alist)) -(defun read-table-as-alist (stream) +(declaim (ftype (function (stream) null) skip-table)) +(defun skip-table (stream) + ;; note that this function partly duplicates parts of other functions/macros + (do ((line (adjust-line (read-line stream nil)) (adjust-line (read-line stream nil)))) + ((or (null line) (string= line "E")) nil) + (cl-ppcre:register-groups-bind + (v) ("^.*[^&]:(.).+$" line) + (if (string= v "T") (skip-table stream))))) + +(declaim (ftype (function (stream &key (:only t)) list) read-table-as-alist)) +(defun read-table-as-alist (stream &key only) (let ((ht ())) (iterate-table-entries - (stream kv vv #'read-table-as-alist) + (stream kv vv #'read-table-as-alist :only only) (let ((c (assoc kv ht :test #'equal))) (if c (setf (cdr c) vv) (push (cons kv vv) ht)))) ht)) -(declaim (ftype (function (stream) hash-table) read-table-as-hash-table)) -(defun read-table-as-hash-table (stream) +(declaim (ftype (function (stream &key (:only t)) hash-table) read-table-as-hash-table)) +(defun read-table-as-hash-table (stream &key only) (let ((ht (make-hash-table :test #'equal))) (iterate-table-entries - (stream kv vv #'read-table-as-hash-table) + (stream kv vv #'read-table-as-hash-table :only only) (setf (gethash kv ht) vv)) ht)) -(defmacro from-stream (stream restype) +(defmacro from-stream (stream restype &rest options) (alexandria:with-gensyms (header sver) (alexandria:once-only (stream) @@ -81,13 +90,13 @@ (,(ecase restype (:alist 'read-table-as-alist) (:hash-table 'read-table-as-hash-table)) - ,stream))))) + ,stream ,@options))))) -(defmacro from-file (filename restype) +(defmacro from-file (filename restype &rest options) (let ((stream (gensym)) (fn (gensym))) `(let ((,fn ,filename)) (with-open-file (,stream ,fn) - (from-stream ,stream ,restype))))) + (from-stream ,stream ,restype ,@options))))) (defmacro with-data-from-file ((var &rest options) &body body) `(let ((,var (from-file ,@options))) ,@body)) diff --git a/tracks/database.lisp b/tracks/database.lisp index a2bca96..1dae1dc 100644 --- a/tracks/database.lisp +++ b/tracks/database.lisp @@ -39,35 +39,32 @@ collect (cons ,c ,d)))))) (defun optimize-track-database (tdb) - (loop for pos in (loop for i being the hash-keys of tdb collect i) - for track = (gethash pos tdb) - when (and track (not (track-special track))) do - (let ((connections (track-connects track)) - (unused (make-array 16 :initial-element nil))) - (labels - ((ndirs (c) - (count-if-not #'null c)) - (connect-dirs (from to dist) - (with-track-at-ts (tdb from nil dir track) - (let ((c (aref (track-connects track) dir))) - (setf (car c) to) - (setf (cadr c) dist))) - (with-track-at-ts (tdb to nil dir track) - (let ((c (aref (track-connects track) dir))) - (setf (car c) from) - (setf (cadr c) dist)))) - (merge-2way (c) - (when (= (ndirs c) 2) - (let ((collapsed (coerce (remove-if #'null c) 'list))) - (connect-dirs (caar collapsed) (caadr collapsed) - (+ (cadar collapsed) (cadadr collapsed)))) - (setf unused (make-array 16 :initial-element t)))) - (removable-p () - (loop for i across unused always i))) + (declare (optimize (debug 3))) + (labels ((ndirs (c) (loop for i across c when i count i)) + (connect-dirs (from to dist) + (with-track-at-ts (tdb from nil dir track) + (let ((c (aref (track-connects track) dir))) + (psetf (car c) to (cadr c) dist))) + (with-track-at-ts (tdb to nil dir track) + (let ((c (aref (track-connects track) dir))) + (psetf (car c) from (cadr c) dist)))) + (merge-2way (c u) + (when (eql (ndirs c) 2) + (let ((collapsed (loop for i across c when i collect i))) + (connect-dirs (caar collapsed) (caadr collapsed) + (+ (cadar collapsed) (cadadr collapsed)))) + (loop for i from 0 to 15 do (setf (aref u i) t)))) + (removable-p (u) + (loop for i across (the (vector t 16) u) always i))) + (loop for pos of-type aux:v3d in (loop for i being the hash-keys of tdb collect i) + for track = (gethash pos tdb) + when (and track (not (track-special track))) do + (let ((connections (track-connects track)) + (unused (make-array 16 :initial-element nil))) (loop for dir from 0 to 15 for i across connections when (null i) do (setf (aref unused dir) t)) - (merge-2way connections) - (when (removable-p) + (merge-2way connections unused) + (when (removable-p unused) (remhash pos tdb)))))) ;;; written based on https://gigamonkeys.com/book/practical-parsing-binary-files.html @@ -100,7 +97,7 @@ (adjust-conns-list-with-param2 clist param2 t)))) tmpdb)))) -(defun import-data (fn) +(defun load-trackdb (fn) (let ((tdb (make-track-database)) (tmpdb (read-tracks-from-nodedb fn))) (loop for pos being the hash-keys of tmpdb using (hash-value clist) diff --git a/tracks/package.lisp b/tracks/package.lisp index 99d4347..255b0c4 100644 --- a/tracks/package.lisp +++ b/tracks/package.lisp @@ -1,6 +1,6 @@ (defpackage :tracks (:use :cl) - (:export :init-tracks :import-data + (:export :init-tracks :load-trackdb :dump-track-definitions :gvdump :trackside :dijkstra)) diff --git a/ywatds.asd b/ywatds.asd index 0d0d5ea..b9d4ba0 100644 --- a/ywatds.asd +++ b/ywatds.asd @@ -27,4 +27,4 @@ #+sb-core-compression (defmethod asdf:perform ((o asdf:image-op) (c asdf:system)) - (uiop:dump-image (asdf:output-file o c) :executable t :compression t)) + (uiop:dump-image (asdf:output-file o c) :executable t :compression 9))