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

Last change on this file since 15278 was 4172, checked in by gb, 14 years ago

WITH-DLL-NODE-FREELIST: syntax to allow specialized list header initialization.

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