crow-httpd: switch from CVS RCSID to GIT revision for versioning
[mmondor.git] / mmsoftware / cl / server / dlist.lisp
CommitLineData
76121551 1;;; $Id: dlist.lisp,v 1.3 2012/09/13 13:10:00 mmondor Exp $
2c7296a6
MM
2
3#|
4
5Copyright (c) 2011, Matthew Mondor
6All rights reserved.
7
8Redistribution and use in source and binary forms, with or without
9modification, are permitted provided that the following conditions
10are met:
111. Redistributions of source code must retain the above copyright
12 notice, this list of conditions and the following disclaimer.
132. Redistributions in binary form must reproduce the above copyright
14 notice, this list of conditions and the following disclaimer in the
15 documentation and/or other materials provided with the distribution.
16
17THIS SOFTWARE IS PROVIDED BY MATTHEW MONDOR ``AS IS'' AND ANY EXPRESS OR
18IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
19OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
20IN NO EVENT SHALL MATTHEW MONDOR BE LIABLE FOR ANY DIRECT, INDIRECT,
21INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
22BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
23USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
24THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
25(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
26THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27
28|#
29
30;;; dlist.lisp - A doubly-linked list implementation for Common Lisp
31
32
33(declaim (optimize (speed 3) (safety 1) (debug 1)))
34
35(defpackage :dlist
36 (:use :cl)
37 (:export #:dlist
38 #:dlist-p
39 #:dlist-first
40 #:dlist-last
41 #:dlist-nodes
42 #:dnode
43 #:dnode-p
44 #:dnode-object
45 #:dnode-prev
46 #:dnode-next
47 #:dnode-alloc
48 #:dnode-free
49 #:with-dnode
50 #:with-dlist
51 #:do-dlist
52 #:map-dlist
53 #:list<-dlist
54 #:dlist<-list
55 #:dlist-reset
56 #:dlist-destroy
57 #:dlist-append
58 #:dlist-insert
59 #:dlist-unlink
60 #:dlist-insert-before
61 #:dlist-swap
62 #:make-dlist))
63
64(in-package :dlist)
65
776ff986 66
2c7296a6
MM
67
68(defstruct
69 (dnode
70 (:constructor %make-dnode ())
71 (:print-object
72 (lambda (o stream)
73 (print-unreadable-object (o stream :type t :identity t)
74 (princ `(:object ,(dnode-object o)) stream)))))
75 "A doubly linked list node, linking NEXT/PREV slots and pointing to OBJECT.
76See: DNODE-ALLOC DNODE-FREE DNODE-OBJECT."
77 (prev nil :type (or null dnode))
78 (next nil :type (or null dnode))
79 object)
80
81(defstruct
82 (dlist
83 (:constructor %make-dlist ())
84 (:print-object
85 (lambda (o stream)
86 (print-unreadable-object (o stream :type t :identity t)
87 (princ `(:nodes ,(dlist-nodes o)) stream)))))
88 "A doubly linked list, linking FIRST/LAST to DNODE objects and storing
89the nodes count. Note that these lists are not automatically thread-safe,
90explicit locks should be used by user code as necessary."
91 (first nil :type (or null dnode))
92 (last nil :type (or null dnode))
93 (nodes 0 :type fixnum))
94
95
96;;; Alloc/free cache for speed and locality
97
98(defparameter *initial-cache-size* 1024)
99
100(defun newlist (size)
101 (let ((list (make-list size)))
102 (loop
103 for n on list
104 do
105 (setf (car n) (%make-dnode)))
106 list))
107
108(defmacro make-lock ()
109 #+ecl'(mp:make-lock)
110 #-ecl'nil)
111
112(defmacro with-lock ((lock) &body body)
113 (let ((s-lock (gensym)))
114 `(let ((,s-lock ,lock))
115 #+ecl(mp:with-lock (,s-lock)
116 ,@body)
117 #-ecl(progn
118 ,@body))))
119
120(let* ((cache-lock (make-lock))
121 (cache-size *initial-cache-size*)
122 (cache-list '()))
123 (declare (type fixnum cache-size))
124
125 ;;; Init
126 (with-lock (cache-lock)
127 (setf cache-list (newlist cache-size)))
128
129 ;;; XXX Use a per-thread cache?
130 (defun dnode-alloc (object)
131 "Allocate a DNODE object, making it point to OBJECT. These objects are
132allocated from a batch-filled cache for performance. Note that this cache
133uses an implicit lock for thread-safety. See: DNODE-FREE."
134 (with-lock (cache-lock)
135 (when (null cache-list)
136 (setf cache-list (newlist cache-size)
137 cache-size (* 2 cache-size)))
138 (let ((dnode (pop cache-list)))
139 (setf (dnode-object dnode) object)
140 dnode)))
141
142 (defun dnode-free (dnode)
143 "Free a previously allocated DNODE object. Note that by default,
144DNODE-UNLINK, DLIST-RESET and DLIST-DESTROY will automatically free these.
145If they're not freed, the GC should be able to reclaim the memory, but
146freeing these objects allows to reuse them soon for better performance."
147 (with-lock (cache-lock)
148 (setf (dnode-prev dnode) nil
149 (dnode-next dnode) nil
150 (dnode-object dnode) nil)
151 (push dnode cache-list)
152 nil)))
153
154(defmacro with-dnode ((var object) &body body)
155 "Macro which allocates a DNODE object, binds it to VAR for the duration
156of BODY and then frees it. Care must be taken not to allow DLINK-UNLINK to
157free VAR within BODY."
158 (let ((s-dnode (gensym)))
159 `(let* ((,s-dnode (dnode-alloc ,object))
160 (,var ,s-dnode))
161 (unwind-protect
162 (progn
163 ,@body)
164 (dnode-free ,s-dnode)))))
165
166(defmacro with-dlist ((var dlist) &body body)
167 "Macro which ensures to free DLIST when done. DLIST is also bound to VAR
168within BODY."
169 (let ((s-dlist (gensym)))
170 `(let* ((,s-dlist ,dlist)
171 (,var ,s-dlist))
172 (unwind-protect
173 (progn
174 ,@body)
175 (dlist-destroy ,s-dlist)))))
176
177(defmacro do-dlist ((var dlist &key (reverse nil)) &body body)
178 "Macro to iterate over every node of DLIST, with the current node bound to
179VAR during BODY. If REVERSE is T (defaults to NIL), the list is iterated
180backwards. Note that this macro takes the necessary precautions such that it
181is possible to use DLIST-UNLINK on VAR during BODY."
182 (let ((dnode-s (gensym))
183 (next-dnode-s (gensym))
184 (dlist-s (gensym)))
185 `(loop
186 with ,dlist-s = ,dlist
187 for ,dnode-s = ,(if reverse
188 `(dlist-last ,dlist-s)
189 `(dlist-first ,dlist-s)) then ,next-dnode-s
190 for ,next-dnode-s = (if ,dnode-s ,(if reverse
191 `(dnode-prev ,dnode-s)
192 `(dnode-next ,dnode-s))
193 nil)
194 while ,dnode-s
195 do
196 (let ((,var ,dnode-s))
197 ,@body))))
198
199(defun list<-dlist (dlist)
200 "Returns a fresh standard LIST containing all objects of DLIST."
201 (loop
202 for dnode = (dlist-first dlist) then (dnode-next dnode)
203 while dnode
204 collect (dnode-object dnode)))
205
206(defun dlist<-list (list)
207 "Returns a fresh DLIST containing all objects of standard LIST."
208 (let ((dlist (%make-dlist)))
209 (loop
210 for o in list
211 do
212 (dlist-append dlist (dnode-alloc o)))
213 dlist))
214
215(defmacro map-dlist (function dlist &key (reverse nil) (results t))
216 "Iterates through DLIST calling FUNCTION with every object (not DNODE).
217If :RESULTS is T (the default), returns a freshly generated DLIST holding
218the objects returned by FUNCTION; returns NIL otherwise.
219If :REVERSE is T (which defaults to NIL), runs through DLIST backwards."
220 (let ((dnode-s (gensym))
221 (dlist-s (gensym))
222 (function-s (gensym))
223 (results-s (gensym)))
224 `(let ((,function-s ,function)
225 (,results-s ,(if results `(%make-dlist) 'nil)))
226 (loop
227 with ,dlist-s = ,dlist
228 for ,dnode-s = ,(if reverse
229 `(dlist-last ,dlist-s)
230 `(dlist-first ,dlist-s))
231 then ,(if reverse
232 `(dnode-prev ,dnode-s)
233 `(dnode-next ,dnode-s))
234 while ,dnode-s
235 do
236 ,(if results
237 `(dlist-append ,results-s
238 (dnode-alloc
239 (funcall ,function-s
240 (dnode-object ,dnode-s))))
241 `(funcall ,function-s (dnode-object ,dnode-s))))
242 ,results-s)))
243
244(defun dlist-reset (dlist &optional (free t))
245 "Resets DLIST, which must already have been created using MAKE-DLIST.
246Emties DLIST, with every existing DNODE in DLIST freed if FREE is T
247(the default)."
248 (when free
249 (do-dlist (dnode dlist)
250 (dnode-free dnode)))
251 (setf (dlist-first dlist) nil
252 (dlist-last dlist) nil
253 (dlist-nodes dlist) 0)
254 nil)
255
256(defmacro dlist-destroy (dlist)
257 "Simple macro around DLIST-RESET."
258 `(dlist-reset ,dlist))
259
76121551 260(declaim (inline dlist-append))
2c7296a6
MM
261(defun dlist-append (dlist dnode)
262 "Appends DNODE to DLIST, returning the number of nodes in DLIST."
263 (let ((lastnode (dlist-last dlist)))
264 (if lastnode
265 (setf (dnode-next lastnode) dnode
266 (dnode-prev dnode) lastnode
267 (dnode-next dnode) nil
268 (dlist-last dlist) dnode)
269 (setf (dlist-first dlist) dnode
270 (dlist-last dlist) dnode
271 (dnode-prev dnode) nil
272 (dnode-next dnode) nil)))
273 (the fixnum (incf (the fixnum (dlist-nodes dlist)))))
274
76121551 275(declaim (inline dlist-insert))
2c7296a6
MM
276(defun dlist-insert (dlist dnode)
277 "Inserts DNODE before every other item in DLIST, returning the number of
278nodes in DLIST."
279 (let ((firstnode (dlist-first dlist)))
280 (if firstnode
281 (setf (dnode-prev firstnode) dnode
282 (dnode-prev dnode) nil
283 (dnode-next dnode) firstnode
284 (dlist-first dlist) dnode)
285 (setf (dlist-first dlist) dnode
286 (dlist-last dlist) dnode
287 (dnode-prev dnode) nil
288 (dnode-next dnode) nil)))
289 (the fixnum (incf (the fixnum (dlist-nodes dlist)))))
290
76121551
MM
291(declaim (inline dlist-unlink))
292(defun dlist-unlink (dlist dnode &optional (free t))
2c7296a6
MM
293 "Unlinks DNODE from DLIST, returning the number of nodes left in DLIST."
294 (let ((prev (dnode-prev dnode))
295 (next (dnode-next dnode)))
296 (if prev
297 (setf (dnode-next prev) next)
298 (setf (dlist-first dlist) next))
299 (if next
300 (setf (dnode-prev next) prev)
301 (setf (dlist-last dlist) prev)))
302 (prog1
303 (the fixnum (decf (the fixnum (dlist-nodes dlist))))
304 (if free
305 (dnode-free dnode))))
306
76121551 307(declaim (inline dlist-insert-before))
2c7296a6
MM
308(defun dlist-insert-before (dlist before-dnode dnode)
309 "Inserts DNODE into DLIST before BEFORE-DNODE which must also be in DLIST.
310Returns the number of nodes in DLIST."
311 (let ((prev (dnode-prev before-dnode))
312 (next before-dnode))
313 (setf (dnode-next dnode) next
314 (dnode-prev next) dnode)
315 (if prev
316 (setf (dnode-next prev) dnode
317 (dnode-prev dnode) prev)
318 (setf (dlist-first dlist) dnode
319 (dnode-prev dnode) nil)))
320 (the fixnum (incf (the fixnum (dlist-nodes dlist)))))
321
322(defmacro dlist-swap (to-dlist from-dlist dnode &key (mode :append))
323 "Macro around DLIST-UNLINK and DLIST-INSERT/DLIST-APPEND. Swaps DNODE
324from FROM-DLIST to TO-DLIST. If MODE can be :APPEND (default) or :INSERT.
325Returns the number of nodes in TO-DLIST. Note that an explicit lock should
326be used in concurrent code to prevent race conditions."
327 (let ((to-dlist-s (gensym))
328 (from-dlist-s (gensym))
329 (dnode-s (gensym)))
330 `(let ((,to-dlist-s ,to-dlist)
331 (,from-dlist-s ,from-dlist)
332 (,dnode-s ,dnode))
333 (dlist-unlink ,from-dlist-s ,dnode-s :free nil)
334 ,(if (eq mode :append)
335 `(dlist-append ,to-dlist-s ,dnode-s)
336 `(dlist-insert ,to-dlist-s ,dnode-s)))))
337
338(defun make-dlist (&rest objects)
339 "Creates a DLIST, filling it with optional OBJECTS, then returns it."
340 (let ((dlist (%make-dlist)))
341 (loop
342 for o in objects
343 do
344 (dlist-append dlist (dnode-alloc o)))
345 dlist))