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

Last change on this file since 15849 was 15849, checked in by gb, 6 years ago

Change handling of inline constants ("the constant pool") in ARM
backend.

Recognize that offsets in floating-point loads are limited to 10 bits.

Don't support :DRAIN-CONSTANT-POOL vinsn directive; replace with
:LOCK-CONSTANT-POOL/:UNLOCK-CONSTANT-POOL, which control the automatic
draining of the constant pool when an unconditional control-transfer
instruction is generated. (This is intended to "protect" things like
jump tables that generate such instructions but don't want to have
floating-point constants embedded in the instruction stream.)

Don't support a "force" argument to ARM-DRAIN-CONSTANT-POOL.

If a constant would be too far away from its referencing instruction
if it was appended to the (current) code segment, embed it at the point
of reference, e.g.

  (fldd d1,:= @x)
  (b 1f)
...
@x (:word ...) (:word)
1:

Fixes ticket:1087 in the trunk.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 8.0 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(defun remove-dll-node-list (head tail)
65  (let* ((prev (dll-node-pred head))
66         (after (dll-node-succ tail)))
67    (setf (dll-node-pred after) prev
68          (dll-node-succ prev) after
69          (dll-node-pred head) nil
70          (dll-node-succ tail) nil)))
71
72
73;;; Splice one or more nodes out of the containing doubly-linked list.
74;;; Return the first and last nodes in the new chain.
75(defun remove-dll-node (node &optional (count 1))
76  (declare (fixnum count))
77  (do* ((last node (dll-node-succ last))
78        (i 1 (1+ i)))
79       ((= i count)
80        (let* ((prev (dll-node-pred node))
81               (after (dll-node-succ last)))
82          (setf (dll-node-pred after) prev
83                (dll-node-succ prev) after
84                (dll-node-pred node) nil
85                (dll-node-succ last) nil)
86          (values node last)))
87    (declare (fixnum i))
88    ;; This check shouldn't cost much and keeps us from doing
89    ;; something really stupid.
90    (when (typep last 'dll-header)
91      (error "Can't remove header node ."))))
92
93;;; Insert one or mode nodes after a specified node.  To be sane, the
94;;; "chainlast" argument must be "node" or a transitive successor of
95;;; "node", (and "node" EQ to or a transitive predecessor of
96;;; "chainlast", and no list header should appear on the chain between
97;;; "node" and "chainlast".  The typical cases where this is used are
98;;; to insert a freshly consed node into a list or to insert a chain
99;;; of one or more freshly deleted nodes.  Both of these cases satisfy
100;;; the sanity check, so it isn't performed here.
101(defun insert-dll-node-after (node after &optional (chainlast node))
102  (let* ((after-after (dll-node-succ after)))
103    (setf (dll-node-pred node) after
104          (dll-node-succ chainlast) after-after
105          (dll-node-pred after-after) chainlast
106          (dll-node-succ after) node)))
107
108;;; More concise, somehow ...
109(defun insert-dll-node-before (node before &optional (chainlast node))
110  (insert-dll-node-after node (dll-node-pred before) chainlast))
111
112(defun move-dll-nodes (node after &optional (count 1))
113  (multiple-value-bind (first last) (remove-dll-node node count)
114    (insert-dll-node-after first after last)))
115
116;;; Return chain head and tail, or (values nil nil) if empty header.
117(defun detach-dll-nodes (header)
118  (let* ((first (dll-header-first header)))
119    (if (eq first header)
120      (values nil nil)
121      (let* ((last (dll-header-last header)))
122        (setf (dll-header-first header) header
123              (dll-header-last header) header
124              (dll-node-pred first) nil
125              (dll-node-succ last) nil)
126        (values first last)))))
127
128(defun merge-dll-nodes (target &rest others)
129  (declare (dynamic-extent others))
130  (dolist (other others target)
131    (multiple-value-bind (head tail) (detach-dll-nodes other)
132      (when head
133        (insert-dll-node-after head (dll-header-last target) tail)))))
134
135;;; This definition doesn't work when the body unlinks "more than" the
136;;; current node.
137(defmacro do-dll-nodes ((valvar header &optional result) &body body)
138  (let* ((headervar (make-symbol "HEADER"))
139         (next (make-symbol "NEXT")))
140    `(do* ((,headervar ,header)
141           (,valvar (dll-header-first ,headervar) ,next)
142           (,next (dll-node-succ ,valvar) (dll-node-succ ,valvar)))
143          ((eq ,valvar ,headervar)
144           ,result)         
145       ,@body)))
146
147(defun dll-header-length (header)
148  (let* ((count 0))
149    (declare (fixnum count))
150    (do-dll-nodes (n header count)
151      (incf count))))
152
153(defun dll-node-position (node header)
154  (let* ((pos 0))
155    (declare (fixnum pos))
156    (do-dll-nodes (n header)
157      (if (eq n node)
158        (return pos)
159        (incf pos)))))
160
161;;; dll-node freelisting ...
162
163(defun make-dll-node-freelist ()
164  (%cons-pool))
165
166;;; header shouldn't be used after this is called
167(defun return-dll-nodes (header freelist)
168  (without-interrupts
169   (let* ((pool-header (pool.data freelist)))
170     (if (null pool-header)
171       (setf (pool.data freelist) header)
172       (multiple-value-bind (first last) (detach-dll-nodes header)
173         (if first
174           (insert-dll-node-after first (dll-header-last pool-header) last))))
175     nil)))
176
177;;; Pop a node off off the freelist; return NIL if the freelist is
178;;; empty.  Set the succ and pred slots of the node to NIL; other
179;;; slots are undefined.
180(defun alloc-dll-node (freelist)
181  (without-interrupts
182   (let* ((pool-header (pool.data freelist))
183          (node (if pool-header (dll-header-first pool-header))))
184     (if (and node (not (eq node pool-header)))
185       (remove-dll-node node)))))
186
187(defun free-dll-node (node freelist)
188  (without-interrupts
189   (let* ((pool-header (pool.data freelist)))
190     (if (null pool-header)
191       (progn
192         (setq pool-header (make-dll-header))
193         (setf (pool.data freelist) pool-header)))
194     (append-dll-node node pool-header)
195     nil)))
196
197(defun remove-and-free-dll-node (node freelist)
198  (remove-dll-node node)
199  (free-dll-node node freelist))
200
201(defmacro with-dll-node-freelist ((header-var freelist) &body body)
202  (let* ((internal-header-name (gensym))
203         (internal-freelist-name (gensym))
204         (constructor-name 'make-dll-header))
205    (if (consp header-var)
206      (setq constructor-name (cadr header-var)
207            header-var (car header-var)))
208    `(let* ((,internal-header-name (,constructor-name))
209            (,internal-freelist-name ,freelist))
210       (unwind-protect
211         (let* ((,header-var ,internal-header-name))
212           ,@body)
213         (return-dll-nodes ,internal-header-name ,internal-freelist-name)))))
214
215(defstruct (locked-dll-header
216             (:include dll-header)
217             (:constructor %make-locked-dll-header))
218  (lock (make-lock)))
219
220(defun make-locked-dll-header ()
221  (init-dll-header (%make-locked-dll-header)))
222
223(defmacro with-locked-dll-header ((h) &body body)
224  `(with-lock-grabbed ((locked-dll-header-lock ,h))
225    ,@body))
226
227(defun locked-dll-header-enqueue (node header)
228  (with-locked-dll-header (header)
229    (append-dll-node node header)))
230
231(defun locked-dll-header-dequeue (header)
232  (with-locked-dll-header (header)
233    (let* ((first (dll-header-first header)))
234      (unless (eq first header)
235        (remove-dll-node first)))))
236
237(provide "DLL-NODE")
Note: See TracBrowser for help on using the repository browser.