source: branches/qres/ccl/compiler/dll-node.lisp @ 15278

Last change on this file since 15278 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.7 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18
19(in-package "CCL")
20
21
22(defstruct (dll-node (:print-function print-dll-node))
23  pred
24  succ)
25
26; Doubly-linked list header (just a distinguished type of node)
27(defstruct (dll-header
28            (:include dll-node)
29            (:constructor %make-dll-header))
30)
31
32
33(defmacro dll-header-last (h) `(dll-header-pred ,h))
34(defmacro dll-header-first (h) `(dll-header-succ ,h))
35
36(defun init-dll-header (h)
37  (setf (dll-header-first h) h
38        (dll-header-last h) h))
39
40(defun make-dll-header ()
41  (init-dll-header (%make-dll-header)))
42
43
44;;; DLL-NODEs are sort of "abstract classes", so we should rarely (if
45;;; ever) have to print one.  On the other hand, they're very circular
46;;; abstract classes ...
47(defun print-dll-node (n stream d)
48  (declare (ignore d))
49  (print-unreadable-object (n stream :type t :identity t)))
50
51;;; Return NODE's list header, if it has one.
52(defun dll-node-header (node)
53  (do* ((n node (dll-node-succ node)))
54       ((or (null n) (typep n 'dll-header)) n)))
55
56;;; Make node be the last node in header's linked list
57(defun append-dll-node (node header)
58  (let* ((last (dll-header-last header)))
59    (setf (dll-node-pred node) last
60          (dll-header-last header) node
61          (dll-node-succ node) header
62          (dll-node-succ last) node)))
63
64;;; Splice one or more nodes out of the containing doubly-linked list.
65;;; Return the first and last nodes in the new chain.
66(defun remove-dll-node (node &optional (count 1))
67  (declare (fixnum count))
68  (do* ((last node (dll-node-succ last))
69        (i 1 (1+ i)))
70       ((= i count)
71        (let* ((prev (dll-node-pred node))
72               (after (dll-node-succ last)))
73          (setf (dll-node-pred after) prev
74                (dll-node-succ prev) after
75                (dll-node-pred node) nil
76                (dll-node-succ last) nil)
77          (values node last)))
78    (declare (fixnum i))
79    ;; This check shouldn't cost much and keeps us from doing
80    ;; something really stupid.
81    (when (typep last 'dll-header)
82      (error "Can't remove header node ."))))
83
84;;; Insert one or mode nodes after a specified node.  To be sane, the
85;;; "chainlast" argument must be "node" or a transitive successor of
86;;; "node", (and "node" EQ to or a transitive predecessor of
87;;; "chainlast", and no list header should appear on the chain between
88;;; "node" and "chainlast".  The typical cases where this is used are
89;;; to insert a freshly consed node into a list or to insert a chain
90;;; of one or more freshly deleted nodes.  Both of these cases satisfy
91;;; the sanity check, so it isn't performed here.
92(defun insert-dll-node-after (node after &optional (chainlast node))
93  (let* ((after-after (dll-node-succ after)))
94    (setf (dll-node-pred node) after
95          (dll-node-succ chainlast) after-after
96          (dll-node-pred after-after) chainlast
97          (dll-node-succ after) node)))
98
99;;; More concise, somehow ...
100(defun insert-dll-node-before (node before &optional (chainlast node))
101  (insert-dll-node-after node (dll-node-pred before) chainlast))
102
103(defun move-dll-nodes (node after &optional (count 1))
104  (multiple-value-bind (first last) (remove-dll-node node count)
105    (insert-dll-node-after first after last)))
106
107;;; Return chain head and tail, or (values nil nil) if empty header.
108(defun detach-dll-nodes (header)
109  (let* ((first (dll-header-first header)))
110    (if (eq first header)
111      (values nil nil)
112      (let* ((last (dll-header-last header)))
113        (setf (dll-header-first header) header
114              (dll-header-last header) header
115              (dll-node-pred first) nil
116              (dll-node-succ last) nil)
117        (values first last)))))
118
119(defun merge-dll-nodes (target &rest others)
120  (declare (dynamic-extent others))
121  (dolist (other others target)
122    (multiple-value-bind (head tail) (detach-dll-nodes other)
123      (when head
124        (insert-dll-node-after head (dll-header-last target) tail)))))
125
126;;; This definition doesn't work when the body unlinks "more than" the
127;;; current node.
128(defmacro do-dll-nodes ((valvar header &optional result) &body body)
129  (let* ((headervar (make-symbol "HEADER"))
130         (next (make-symbol "NEXT")))
131    `(do* ((,headervar ,header)
132           (,valvar (dll-header-first ,headervar) ,next)
133           (,next (dll-node-succ ,valvar) (dll-node-succ ,valvar)))
134          ((eq ,valvar ,headervar)
135           ,result)         
136       ,@body)))
137
138(defun dll-header-length (header)
139  (let* ((count 0))
140    (declare (fixnum count))
141    (do-dll-nodes (n header count)
142      (incf count))))
143
144(defun dll-node-position (node header)
145  (let* ((pos 0))
146    (declare (fixnum pos))
147    (do-dll-nodes (n header)
148      (if (eq n node)
149        (return pos)
150        (incf pos)))))
151
152;;; dll-node freelisting ...
153
154(defun make-dll-node-freelist ()
155  (%cons-pool))
156
157;;; header shouldn't be used after this is called
158(defun return-dll-nodes (header freelist)
159  (without-interrupts
160   (let* ((pool-header (pool.data freelist)))
161     (if (null pool-header)
162       (setf (pool.data freelist) header)
163       (multiple-value-bind (first last) (detach-dll-nodes header)
164         (if first
165           (insert-dll-node-after first (dll-header-last pool-header) last))))
166     nil)))
167
168;;; Pop a node off off the freelist; return NIL if the freelist is
169;;; empty.  Set the succ and pred slots of the node to NIL; other
170;;; slots are undefined.
171(defun alloc-dll-node (freelist)
172  (without-interrupts
173   (let* ((pool-header (pool.data freelist))
174          (node (if pool-header (dll-header-first pool-header))))
175     (if (and node (not (eq node pool-header)))
176       (remove-dll-node node)))))
177
178(defun free-dll-node (node freelist)
179  (without-interrupts
180   (let* ((pool-header (pool.data freelist)))
181     (if (null pool-header)
182       (progn
183         (setq pool-header (make-dll-header))
184         (setf (pool.data freelist) pool-header)))
185     (append-dll-node node pool-header)
186     nil)))
187
188(defun remove-and-free-dll-node (node freelist)
189  (remove-dll-node node)
190  (free-dll-node node freelist))
191
192(defmacro with-dll-node-freelist ((header-var freelist) &body body)
193  (let* ((internal-header-name (gensym))
194         (internal-freelist-name (gensym))
195         (constructor-name 'make-dll-header))
196    (if (consp header-var)
197      (setq constructor-name (cadr header-var)
198            header-var (car header-var)))
199    `(let* ((,internal-header-name (,constructor-name))
200            (,internal-freelist-name ,freelist))
201       (unwind-protect
202         (let* ((,header-var ,internal-header-name))
203           ,@body)
204         (return-dll-nodes ,internal-header-name ,internal-freelist-name)))))
205
206(defstruct (locked-dll-header
207             (:include dll-header)
208             (:constructor %make-locked-dll-header))
209  (lock (make-lock)))
210
211(defun make-locked-dll-header ()
212  (init-dll-header (%make-locked-dll-header)))
213
214(defmacro with-locked-dll-header ((h) &body body)
215  `(with-lock-grabbed ((locked-dll-header-lock ,h))
216    ,@body))
217
218(defun locked-dll-header-enqueue (node header)
219  (with-locked-dll-header (header)
220    (append-dll-node node header)))
221
222(defun locked-dll-header-dequeue (header)
223  (with-locked-dll-header (header)
224    (let* ((first (dll-header-first header)))
225      (unless (eq first header)
226        (remove-dll-node first)))))
227
228(provide "DLL-NODE")
Note: See TracBrowser for help on using the repository browser.