diff --git a/dataserver.lisp b/dataserver.lisp index b9b5311..4910391 100644 --- a/dataserver.lisp +++ b/dataserver.lisp @@ -11,6 +11,7 @@ ;; Command-line arguments (defparameter *debugp* nil) +(defparameter *gcp* nil) (defparameter *world-path* nil) ;; Note: do NOT change *server-port* and *server* at debug time (defparameter *server-port* nil) @@ -32,6 +33,8 @@ (tracks:import-data *nodedb*) (psetf *trackdb* ,tdb *trackdb-temp* ,tdbtemp))) (setf *trackdb* (tracks:import-data (ndb:import-data (savefilepath "ndb4.ls"))))) + (when *gcp* + #+sbcl(sb-ext:gc :full t)) (hunchentoot:acceptor-log-message *server* :info "Database updated")))) (defmacro mainloop () @@ -42,6 +45,7 @@ (setf *world-path* (ensure-world-path (car argv))) (setf *server-port* (coerce (parse-integer (cadr argv)) '(integer 0 65535))) (setf *debugp* (member "--debug" (cddr argv) :test #'string=)) + (setf *gcp* (member "--force-periodic-gc" (cddr argv) :test #'string=)) (setf *server* (make-instance 'easy-routes:routes-acceptor :port *server-port*)) (register-routes) (register-debugging-routes) @@ -156,6 +160,7 @@ (defun start-server () (tracks:init-tracks) + (load-data) (hunchentoot:start *server*) ;; loop until an error occurs (if *debugp* (mainloop) (handler-case (mainloop) diff --git a/tracks/conns.lisp b/tracks/conns.lisp index 29a78b5..5039dca 100644 --- a/tracks/conns.lisp +++ b/tracks/conns.lisp @@ -1,5 +1,8 @@ (in-package :tracks) +(defparameter *dir-shared* nil) +(defparameter *conns-shared* nil) + (defstruct trackside (:pos (error "no coordinates specified") :type aux:v3d) (:side (error "no side specified") :type (integer 0 15))) @@ -34,46 +37,69 @@ (print-unreadable-object (obj s) (format s "FROM ~a TO ~a" (conns-from obj) (conns-to obj)))) -(defmacro dir (c &optional r) - `(make-dir :c (or ,c 0) :r (or ,r 0))) +(defun init-shared-dirs () + (setf *dir-shared* (make-array 32 :element-type 'dir :adjustable nil :initial-contents + (loop for i from 0 to 31 collect + (make-dir :c (ash i -1) :r (mod i 2))))) + (setf *conns-shared* (coerce (loop for i from 0 to 1023 collect + (make-conns :from (aref *dir-shared* (ash i -5)) + :to (aref *dir-shared* (mod i 32)))) + '(vector conns 1024)))) -(defmacro conns (c1 c2 &optional r1 r2) - `(make-conns :from (dir ,c1 ,r1) :to (dir ,c2 ,r2))) +(defmacro dir (c &optional r shared) + (alexandria:with-gensyms (cc rc) + `(let ((,cc (the (integer 0 15) ,c)) (,rc (the (integer 0 1) (or ,r 1)))) + (if ,shared (aref *dir-shared* (+ (* 2 ,cc) ,rc)) + (make-dir :c ,cc :r ,rc))))) -(defmacro conns-t ((c1 &body cb) (&optional r1 &body rb)) +(defmacro conns (c1 c2 &optional r1 r2 shared) + (alexandria:with-gensyms (cf ct rf rt) + `(let ((,cf (the (integer 0 15) ,c1)) (,ct (the (integer 0 15) ,c2)) + (,rf (the (integer 0 1) (or ,r1 0))) (,rt (the (integer 0 1) (or ,r2 0)))) + (if ,shared (aref *conns-shared* (+ (ash ,cf 6) (ash ,rf 5) (ash ,ct 1) ,rt)) + (make-conns :from (dir ,c1 ,r1) :to (dir ,c2 ,r2)))))) + +(defmacro dirs->conns (from to &optional shared) + (alexandria:once-only + (from to) + `(if ,shared (conns (dir-c ,from) (dir-c ,to) (dir-r ,from) (dir-r ,to) t) + (make-conns :from ,from :to ,to)))) + +(defmacro conns-t ((c1 &body cb) (&optional r1 &body rb) &optional shared) ``(,,@(loop for c in cb and ri = rb then (cdr ri) for r = (car ri) - collect `(conns ,c1 ,c ,r1 ,r)))) + collect `(conns ,c1 ,c ,r1 ,r ,shared)))) -(defmacro conns-x ((&body cb) (&body rb)) +(defmacro conns-x ((&body cb) (&body rb) &optional shared) ``(,,@(loop for (c1 c2) on cb by #'cddr and r = rb then (cddr rb) for r1 = (car r) and r2 = (cadr r) - collect `(conns ,c1 ,c2 ,r1 ,r2)))) + collect `(conns ,c1 ,c2 ,r1 ,r2 ,shared)))) -(defmacro adjust-dir (dir diff) +(defmacro adjust-dir (dir diff &optional shared) (alexandria:once-only (dir) - `(dir (mod (+ 16 (or ,diff 0) (dir-c ,dir)) 16) (dir-r ,dir)))) + `(dir (mod (+ 16 (or ,diff 0) (dir-c ,dir)) 16) (dir-r ,dir) ,shared))) -(defmacro adjust-conns (conns diff) +(defmacro adjust-conns (conns diff &optional shared) (alexandria:once-only - (conns diff) - `(make-conns :from (adjust-dir (conns-from ,conns) ,diff) - :to (adjust-dir (conns-to ,conns) ,diff)))) + (conns diff shared) + `(dirs->conns (adjust-dir (conns-from ,conns) ,diff ,shared) + (adjust-dir (conns-to ,conns) ,diff ,shared) + ,shared))) -(defmacro adjust-conns-list (clist diff) +(defmacro adjust-conns-list (clist diff &optional shared) (alexandria:with-gensyms (i) (alexandria:once-only - (diff) - `(loop for ,i in ,clist collect (adjust-conns ,i ,diff))))) + (diff shared) + `(loop for ,i in ,clist collect (adjust-conns ,i ,diff ,shared))))) -(defmacro adjust-dir-with-param2 (dir param2) - `(adjust-dir ,dir (* 4 ,param2))) +(defmacro adjust-dir-with-param2 (dir param2 &optional shared) + `(adjust-dir ,dir (* 4 ,param2) ,shared)) -(defmacro adjust-conns-with-param2 (conns param2) - `(adjust-conns ,conns (* 4 ,param2))) +(defmacro adjust-conns-with-param2 (conns param2 &optional shared) + `(adjust-conns ,conns (* 4 ,param2) ,shared)) -(defmacro adjust-conns-list-with-param2 (clist param2) - `(adjust-conns-list ,clist (* 4 ,param2))) +(defmacro adjust-conns-list-with-param2 (clist param2 &optional shared) + `(adjust-conns-list ,clist (* 4 ,param2) ,shared)) (defmacro apply-dir-to-v3d (pos dir) (alexandria:with-gensyms (h) diff --git a/tracks/database.lisp b/tracks/database.lisp index d07a762..a9d45d0 100644 --- a/tracks/database.lisp +++ b/tracks/database.lisp @@ -77,7 +77,7 @@ (ndb:loopdb (ndb pos node param2) (alexandria:when-let ((clist (gethash node *track->conns*))) - (setf (gethash pos tmpdb) (adjust-conns-list-with-param2 clist param2)))) + (setf (gethash pos tmpdb) (adjust-conns-list-with-param2 clist param2 t)))) (loop for pos being the hash-keys of tmpdb using (hash-value clist) for dirs = (conns-list-dirs clist) for connects = (make-empty-connects) do diff --git a/tracks/registration.lisp b/tracks/registration.lisp index 837bb2a..2973e32 100644 --- a/tracks/registration.lisp +++ b/tracks/registration.lisp @@ -13,7 +13,7 @@ (names conns) `(loop for ,i = 0 then (1+ ,i) for ,s in `("" "_30" "_45" "_60") for ,n = (loop for ,j in ,names collect (concatenate 'string ,j ,s)) - do (register-tracks ,n (adjust-conns-list ,conns ,i)))))) + do (register-tracks ,n (adjust-conns-list ,conns ,i t)))))) (defmacro prefix-names (prefix &body names) (alexandria:once-only @@ -35,59 +35,60 @@ (defmacro register-default-tracks (prefix) `(register-rotatable-track-with-preset ,prefix - (("st") (conns-t (0 8) ())) - (("cr") (conns-t (0 7) ())) - (("swlst" "swlcr") (conns-t (0 8 7) ())) - (("swrst" "swrcr") (conns-t (0 8 9) ())))) + (("st") (conns-t (0 8) () t)) + (("cr") (conns-t (0 7) () t)) + (("swlst" "swlcr") (conns-t (0 8 7) () t)) + (("swrst" "swrcr") (conns-t (0 8 9) () t)))) (defmacro register-y-turnout-tracks (prefix) `(register-rotatable-track-with-preset ,prefix - (("l" "r") (conns-t (0 7 9) ())))) + (("l" "r") (conns-t (0 7 9) () t)))) (defmacro register-3way-turnout-tracks (prefix) `(register-rotatable-track-with-preset ,prefix - (("l" "s" "r") (conns-t (0 7 8 9) ())))) + (("l" "s" "r") (conns-t (0 7 8 9) () t)))) (defmacro register-slope-tracks (prefix) `(register-rotatable-track-with-preset ,prefix - (("vst1" "vst31" "vst32") (conns-t (8 0) (0 0))) - (("vst2" "vst33") (conns-t (8 0) (0 1))))) + (("vst1" "vst31" "vst32") (conns-t (8 0) (0 0) t)) + (("vst2" "vst33") (conns-t (8 0) (0 1) t)))) (defmacro register-straightonly-tracks (prefix) `(register-rotatable-track-with-preset ,prefix - (("st") (conns-t (0 8) ())))) + (("st") (conns-t (0 8) () t)))) (defmacro register-perp-xing-tracks (prefix) `(register-rotatable-track-with-preset ,prefix - (("st") (conns-x (0 8 4 12) ())))) + (("st") (conns-x (0 8 4 12) () t)))) (defmacro register-90+x-xing-tracks (prefix) `(register-track-with-preset ,prefix - (("30l") (conns-x (0 8 1 9) ())) - (("45l") (conns-x (0 8 2 10) ())) - (("60l") (conns-x (0 8 3 11) ())) - (("60r") (conns-x (0 8 5 13) ())) - (("45r") (conns-x (0 8 6 14) ())) - (("30r") (conns-x (0 8 7 15) ())))) + (("30l") (conns-x (0 8 1 9) () t)) + (("45l") (conns-x (0 8 2 10) () t)) + (("60l") (conns-x (0 8 3 11) () t)) + (("60r") (conns-x (0 8 5 13) () t)) + (("45r") (conns-x (0 8 6 14) () t)) + (("30r") (conns-x (0 8 7 15) () t)))) (defmacro register-diag-xing-tracks (prefix) `(register-track-with-preset ,prefix - (("30l45r") (conns-x (1 9 6 14) ())) - (("60l30l") (conns-x (3 11 1 9) ())) - (("60l45r") (conns-x (3 11 6 14) ())) - (("60l60r") (conns-x (3 11 5 13) ())) - (("60r45l") (conns-x (5 13 2 10) ())) - (("60r30r") (conns-x (5 13 7 15) ())) - (("30r45l") (conns-x (7 15 2 10) ())))) + (("30l45r") (conns-x (1 9 6 14) () t)) + (("60l30l") (conns-x (3 11 1 9) () t)) + (("60l45r") (conns-x (3 11 6 14) () t)) + (("60l60r") (conns-x (3 11 5 13) () t)) + (("60r45l") (conns-x (5 13 2 10) () t)) + (("60r30r") (conns-x (5 13 7 15) () t)) + (("30r45l") (conns-x (7 15 2 10) () t)))) (defun init-tracks () + (init-shared-dirs) (setf *track->conns* (make-hash-table :test #'equal)) (register-default-tracks "advtrains:dtrack") (register-y-turnout-tracks "advtrains:dtrack_sy")