source: trunk/source/compiler/dll-node.lisp

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 8.6 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;; Copyright 1994-2009 Clozure Associates
4;;;
5;;; Licensed under the Apache License, Version 2.0 (the "License");
6;;; you may not use this file except in compliance with the License.
7;;; You may obtain a copy of the License at
8;;;
9;;;     http://www.apache.org/licenses/LICENSE-2.0
10;;;
11;;; Unless required by applicable law or agreed to in writing, software
12;;; distributed under the License is distributed on an "AS IS" BASIS,
13;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14;;; See the License for the specific language governing permissions and
15;;; limitations under the License.
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  info
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-info h) nil
38        (dll-header-first h) h
39        (dll-header-last h) h))
40
41(defun make-dll-header ()
42  (init-dll-header (%make-dll-header)))
43
44
45;;; DLL-NODEs are sort of "abstract classes", so we should rarely (if
46;;; ever) have to print one.  On the other hand, they're very circular
47;;; abstract classes ...
48(defun print-dll-node (n stream d)
49  (declare (ignore d))
50  (print-unreadable-object (n stream :type t :identity t)))
51
52;;; Return NODE's list header, if it has one.
53(defun dll-node-header (node)
54  (do* ((n node (dll-node-succ node)))
55       ((or (null n) (typep n 'dll-header)) n)))
56
57;;; Make node be the last node in header's linked list
58(defun append-dll-node (node header)
59  (let* ((last (dll-header-last header)))
60    (setf (dll-node-pred node) last
61          (dll-header-last header) node
62          (dll-node-succ node) header
63          (dll-node-succ last) node)))
64
65(defun pop-dll-node (header)
66  (let* ((first (dll-header-first header)))
67    (unless (eq first header)
68      (values (remove-dll-node first)))))
69
70(defun remove-dll-node-list (head tail)
71  (let* ((prev (dll-node-pred head))
72         (after (dll-node-succ tail)))
73    (setf (dll-node-pred after) prev
74          (dll-node-succ prev) after
75          (dll-node-pred head) nil
76          (dll-node-succ tail) nil)))
77
78
79;;; Splice one or more nodes out of the containing doubly-linked list.
80;;; Return the first and last nodes in the new chain.
81(defun remove-dll-node (node &optional (count 1))
82  (declare (fixnum count))
83  (do* ((last node (dll-node-succ last))
84        (i 1 (1+ i)))
85       ((= i count)
86        (let* ((prev (dll-node-pred node))
87               (after (dll-node-succ last)))
88          (setf (dll-node-pred after) prev
89                (dll-node-succ prev) after
90                (dll-node-pred node) nil
91                (dll-node-succ last) nil)
92          (values node last)))
93    (declare (fixnum i))
94    ;; This check shouldn't cost much and keeps us from doing
95    ;; something really stupid.
96    (when (typep last 'dll-header)
97      (error "Can't remove header node ."))))
98
99;;; Insert one or mode nodes after a specified node.  To be sane, the
100;;; "chainlast" argument must be "node" or a transitive successor of
101;;; "node", (and "node" EQ to or a transitive predecessor of
102;;; "chainlast", and no list header should appear on the chain between
103;;; "node" and "chainlast".  The typical cases where this is used are
104;;; to insert a freshly consed node into a list or to insert a chain
105;;; of one or more freshly deleted nodes.  Both of these cases satisfy
106;;; the sanity check, so it isn't performed here.
107(defun insert-dll-node-after (node after &optional (chainlast node))
108  (let* ((after-after (dll-node-succ after)))
109    (setf (dll-node-pred node) after
110          (dll-node-succ chainlast) after-after
111          (dll-node-pred after-after) chainlast
112          (dll-node-succ after) node)))
113
114;;; More concise, somehow ...
115(defun insert-dll-node-before (node before &optional (chainlast node))
116  (insert-dll-node-after node (dll-node-pred before) chainlast))
117
118(defun move-dll-nodes (node after &optional (count 1))
119  (multiple-value-bind (first last) (remove-dll-node node count)
120    (insert-dll-node-after first after last)))
121
122;;; Return chain head and tail, or (values nil nil) if empty header.
123(defun detach-dll-nodes (header)
124  (let* ((first (dll-header-first header)))
125    (if (eq first header)
126      (values nil nil)
127      (let* ((last (dll-header-last header)))
128        (setf (dll-header-first header) header
129              (dll-header-last header) header
130              (dll-node-pred first) nil
131              (dll-node-succ last) nil)
132        (values first last)))))
133
134(defun merge-dll-nodes (target &rest others)
135  (declare (dynamic-extent others))
136  (dolist (other others target)
137    (multiple-value-bind (head tail) (detach-dll-nodes other)
138      (when head
139        (insert-dll-node-after head (dll-header-last target) tail)))))
140
141;;; This definition doesn't work when the body unlinks "more than" the
142;;; current node.
143
144(defmacro do-dll-nodes ((valvar header &optional result) &body body)
145  (let* ((headervar (make-symbol "HEADER"))
146         (next (make-symbol "NEXT")))
147    `(do* ((,headervar ,header)
148           (,valvar (dll-header-first ,headervar) ,next)
149           (,next (dll-node-succ ,valvar) (dll-node-succ ,valvar)))
150          ((eq ,valvar ,headervar)
151           ,result)         
152       ,@body)))
153
154;; skip the head, walk the tail.
155
156(defmacro do-tail-dll-nodes ((valvar header &optional result) &body body)
157  (let* ((headervar (make-symbol "HEADER"))
158         (next (make-symbol "NEXT")))
159    `(do* ((,headervar ,header)
160           (,valvar (dll-node-succ (dll-header-first ,headervar)) ,next)
161           (,next (dll-node-succ ,valvar) (dll-node-succ ,valvar)))
162          ((eq ,valvar ,headervar)
163           ,result)         
164       ,@body)))
165
166(defun dll-header-length (header)
167  (let* ((count 0))
168    (declare (fixnum count))
169    (do-dll-nodes (n header count)
170      (incf count))))
171
172(defun dll-node-position (node header)
173  (let* ((pos 0))
174    (declare (fixnum pos))
175    (do-dll-nodes (n header)
176      (if (eq n node)
177        (return pos)
178        (incf pos)))))
179
180;;; dll-node freelisting ...
181
182(defun make-dll-node-freelist ()
183  (%cons-pool))
184
185;;; header shouldn't be used after this is called
186(defun return-dll-nodes (header freelist)
187  (without-interrupts
188   (let* ((pool-header (pool.data freelist)))
189     (if (null pool-header)
190       (setf (pool.data freelist) header)
191       (multiple-value-bind (first last) (detach-dll-nodes header)
192         (if first
193           (insert-dll-node-after first (dll-header-last pool-header) last))))
194     nil)))
195
196;;; Pop a node off off the freelist; return NIL if the freelist is
197;;; empty.  Set the succ and pred slots of the node to NIL; other
198;;; slots are undefined.
199(defun alloc-dll-node (freelist)
200  (without-interrupts
201   (let* ((pool-header (pool.data freelist))
202          (node (if pool-header (dll-header-first pool-header))))
203     (if (and node (not (eq node pool-header)))
204       (remove-dll-node node)))))
205
206(defun free-dll-node (node freelist)
207  (without-interrupts
208   (let* ((pool-header (pool.data freelist)))
209     (if (null pool-header)
210       (progn
211         (setq pool-header (make-dll-header))
212         (setf (pool.data freelist) pool-header)))
213     (append-dll-node node pool-header)
214     nil)))
215
216(defun remove-and-free-dll-node (node freelist)
217  (remove-dll-node node)
218  (free-dll-node node freelist))
219
220(defmacro with-dll-node-freelist ((header-var freelist) &body body)
221  (let* ((internal-header-name (gensym))
222         (internal-freelist-name (gensym))
223         (constructor-name 'make-dll-header))
224    (if (consp header-var)
225      (setq constructor-name (cadr header-var)
226            header-var (car header-var)))
227    `(let* ((,internal-header-name (,constructor-name))
228            (,internal-freelist-name ,freelist))
229       (unwind-protect
230         (let* ((,header-var ,internal-header-name))
231           ,@body)
232         (return-dll-nodes ,internal-header-name ,internal-freelist-name)))))
233
234(defstruct (locked-dll-header
235             (:include dll-header)
236             (:constructor %make-locked-dll-header))
237  (lock (make-lock)))
238
239(defun make-locked-dll-header ()
240  (init-dll-header (%make-locked-dll-header)))
241
242(defmacro with-locked-dll-header ((h) &body body)
243  `(with-lock-grabbed ((locked-dll-header-lock ,h))
244    ,@body))
245
246(defun locked-dll-header-enqueue (node header)
247  (with-locked-dll-header (header)
248    (append-dll-node node header)))
249
250(defun locked-dll-header-dequeue (header)
251  (with-locked-dll-header (header)
252    (let* ((first (dll-header-first header)))
253      (unless (eq first header)
254        (remove-dll-node first)))))
255
256(provide "DLL-NODE")
Note: See TracBrowser for help on using the repository browser.