source: branches/qres/ccl/library/hash-cons.lisp

Last change on this file 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: 17.1 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2005-2009 Clozure Associates
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL 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;;; Low-level support for hash-consing.
18
19(in-package "CCL")
20
21(defpackage "OPENMCL-HONS"
22  (:use "CL")
23  (:nicknames "HONS")
24  (:export "HONS-INDEX-USED-P" "HONS-SPACE-DELETED-MARKER"
25           "HONS-SPACE-FREE-MARKER"
26           "HONS-SPACE-SIZE" "HONSP" "HONS-FROM-INDEX"
27            "HONS-SPACE-REF-CAR" "HONS-SPACE-REF-CDR"
28           "HONS-SPACE-CONS" "DELETED-HONS-COUNT" "INVALID-HONS-INDEX"
29           "INVALID-HONS-INDEX-INDEX"))
30
31
32;;; At this level. the API is basically:
33;;;
34;;;
35;;; (OPENMCL-HONS:HONS-SPACE-DELETED-MARKER) [MACRO]
36;;; Returns another constant value used to indicate a
37;;; "deleted" cell in a HONS hash table; the CAR and CDR of
38;;; a pair are set to this value by the GC if the HONS which
39;;; addresses that pair becomes garbage.  This value is used
40;;; in Clozure CL to denote unbound slots in STANDARD-INSTANCEs,
41;;; so setting a slot in a standard-instance to this value
42;;; is roughly equivalent to calling SLOT-MAKUNBOUND.  This
43;;; value prints as #<Slot-Unbound>.
44;;;
45;;; (OPENMCL-HONS:HONS-SPACE-FREE-MARKER) [MACRO]
46;;; Returns another constant value used to indicate a
47;;; "free" cell in a HONS hash table; the CAR and CDR of
48;;; a pair are initially set to this value by the GC if the HONS which
49;;; addresses that pair becomes garbage.  This value is used
50;;; in Clozure CL to denote unbound special variabls
51;;; setting a special variable to this value
52;;; is roughly equivalent to calling MAKUNBOUND.  This
53;;; value prints as #<Unbound>.
54
55;;; (OPENCL-HONS:HONS-SPACE-SIZE)
56;;; Returns a non-negative integer denoting the number of
57;;; statically allocated pairs reserved for hash consing.
58;;;
59;;; OPENMCL-HONS:HONS-SPACE-SIZE can be used with SETF, to specify a
60;;; new size in pairs.  The new size should be a non-negative
61;;; fixnum.  If the new size is less than the current size,
62;;; any references to HONSes whose index is between the
63;;; current and new size will be set to NIL.           
64;;; Otherwise, any newly allocated pairs will have their CAR and CDR both
65;;; set to the value returned by (OPENMCL-HONS:HONS-SPACE-FREE).
66;;;
67;;; (OPENMCL-HONS:HONSP <thing>)
68;;; If <thing> is a CONS and is allocated within hons-space,
69;;; returns the index of the pair addressed by <thing> (e.g.,
70;;; the return value will be a non-negative integer less than
71;;; (OPENMCL-HONS:HONS-SPACE-SIZE).  If <thing> is not a CONS or is not
72;;; allocated within hons-space, returns NIL.
73;;;
74;;; (OPENCL-HONS:HONS-FROM-INDEX <index>) If <index> is a non-negative
75;;; integer less than (OPENMCL-HONS:HONS-SPACE-SIZE), returns a
76;;; CONS-typed pointer to the <index>th pair in hons-space.  (If
77;;; <thing> is a HONS, then (EQ (OPENMCL-HONS:HONS-FROM-INDEX
78;;; (OPENMCL-HONS:HONSP <thing>)) <thing>) is true).  Signals an error
79;;; of type OPENMCL-HONS:INVALID-HONS-INDEX if <index> is a fixnum but
80;;; not a valid index.  Signals a TYPE-ERROR if <index> is not a fixum.
81;;;
82;;; (OPENMCL-HONS:HONS-SPACE-REF-CAR <index>)
83;;; (OPENMCL-HONS:HONS-SPACE-REF-CDR <index>)
84;;; Semantically equivalent to (CAR (OPENMCL-HONS:HONS-FROM-INDEX <index>)) and
85;;; (CDR (OPENMCL-HONS:HONS-FROM-INDEX <index>)), respectively.  (May not be
86;;; implemented in a way that actually calls OPENMCL-HONS:HONS-FROM-INDEX.)
87;;;
88;;; (OPENMCL-HONS:HONS-SPACE-CONS <index> <new-car> <new-cdr>)
89;;; Equivalent to:
90;;; (let* ((x (OPENMCL-HONS:HONS-FROM-INDEX <index>)))
91;;;   (setf (car x) <new-car>
92;;;         (cdr x) <new-cdr>)
93;;;   x)
94;;;
95;;; (OPENMCL-HONS:HONS-INDEX-USED-P <index>)
96;;; If <index> is a valid index, returns a Lisp boolean indicating
97;;; whether or not
98;;; (a) OPENMCL-HONS:HONS-FROM-INDEX has been called on it
99;;; and (b) the GC has not marked the index as being deleted
100;;; are both true.
101
102;;; (OPENMCL-HONS:DELETED-HONS-COUNT)
103;;; Returns the total number of pairs in hons space that the GC has deleted
104;;; (because they were unreachable); a "deleted" pair has its CAR and CDR
105;;; set to the value of (OPENMCL-HONS:HONS-DELETED-MARKER), but (since these
106;;; things are statically allocated) the space that the pair occupied remains
107;;; part of hons space.
108;;; Information about the number of deleted pairs may help to guide hashing
109;;; algorithms, but it's not yet clear whether this global count is that
110;;; useful; it may be replaced or extended in the future.
111
112
113(define-condition openmcl-hons:invalid-hons-index ()
114  ((index :initarg :index :reader openmcl-hons:invalid-hons-index-index))
115  (:report (lambda (c s)
116             (format s "Invalid HONS index ~s ."
117                     (openmcl-hons:invalid-hons-index-index c)))))
118
119
120(defmacro openmcl-hons:hons-space-deleted-marker ()
121  "Returns the value used to indicate deleted HONS cells."
122  (%slot-unbound-marker))
123
124(defmacro openmcl-hons:hons-space-free-marker ()
125  "Returns the value used to indicate free HONS cells."
126  (%unbound-marker))
127
128(defun (setf openmcl-hons:hons-space-size) (npairs)
129  "Argument NPAIRS should be a non-negative fixnum.  Tries to grow or
130   shrink the static hons area so that it contains NPAIRS pairs.
131   NPAIRS may be rounded to the next multiple of the machine word size.
132   Returns the number of pairs in the HONS space after it's made the
133   (possibly unsuccessful) attempt.  (Attempts to increase HONS space
134   size may fail if insufficient address space is available.)
135   If NPAIRS is less than the current hons space size, any \"dangling\"
136   references to HONS cells in the deleted region will be set to NIL."
137  (check-type npairs (integer 0 #.(- (1+ target::most-positive-fixnum)
138                                     target::nbits-in-word)))
139  (set-hons-space-size npairs))
140
141#+ppc-target
142(defppclapfunction set-hons-space-size ((npairs arg_z))
143  (check-nargs 1)
144  (mflr loc-pc)
145  #+ppc32-target
146  (bla .SPgetu32)
147  #+ppc64-target
148  (bla .SPgetu64)
149  (mtlr loc-pc)
150  (mr imm1 imm0)
151  (li imm0 arch::gc-trap-function-set-hons-area-size)
152  (trlgei allocptr 0)
153  #+ppc32-target
154  (ba .SPmakeu32)
155  #+ppc64-target
156  (ba .SPmakeu64))
157
158
159#+x8664-target
160(defx86lapfunction set-hons-space-size ((npairs arg_z))
161  (check-nargs 1)
162  (save-simple-frame)
163  (call-subprim .SPgetu64)
164  (movq (% imm0) (% imm1))
165  (movq ($ arch::gc-trap-function-set-hons-area-size) (% imm0))
166  (uuo-gc-trap)
167  (restore-simple-frame)
168  (jmp-subprim .SPmakeu64))
169
170(defun openmcl-hons:hons-space-size ()
171  "Returns the current size of the static hons area."
172  (%fixnum-ref-natural (%get-kernel-global 'tenured-area)
173                       target::area.static-dnodes))
174
175#+ppc-target
176(defppclapfunction openmcl-hons:honsp ((thing arg_z))
177  "If THING is a CONS cell allocated in the hons area, return an integer
178   which denotes that cell's index in hons space - an integer between
179   0 (inclusive) and the hons-space size (exclusive).  Otherwise, return
180   NIL."
181  (check-nargs 1)
182  (extract-fulltag imm2 thing)
183  (ref-global imm0 tenured-area)
184  (cmpri cr2 imm2 target::fulltag-cons)
185  (ldr imm1 target::area.static-dnodes imm0)
186  (ldr imm0 target::area.low imm0)
187  (slri imm1 imm1 (1+ target::word-shift))
188  (bne cr2 @no)
189  (add imm1 imm0 imm1)
190  (cmpr cr0 thing imm0)
191  (cmpr cr1 thing imm1)
192  (blt cr0 @no)
193  (bgt cr1 @no)
194  (subi arg_z arg_z target::fulltag-cons)
195  (sub arg_z arg_z imm0)
196  (srri arg_z arg_z 1)
197  (blr)
198  @no
199  (li arg_z nil)
200  (blr))
201
202#+x8664-target
203(defx86lapfunction openmcl-hons:honsp ((thing arg_z))
204  "If THING is a CONS cell allocated in the hons area, return an integer
205   which denotes that cell's index in hons space - an integer between
206   0 (inclusive) and the hons-space size (exclusive).  Otherwise, return
207   NIL."
208  (check-nargs 1)
209  (extract-fulltag thing imm1)
210  (ref-global tenured-area imm0)
211  (cmpb ($ target::fulltag-cons) (% imm1.b))
212  (movq (@ target::area.static-dnodes (% imm0)) (% imm1))
213  (movq (@ target::area.low (% imm0)) (% imm0))
214  (jne @no)
215  (shr ($ (1+ target::word-shift)) (% imm1))
216  (add (% imm0) (% imm1))
217  (rcmpq (% thing) (% imm0))
218  (jb @no)
219  (rcmpq (% thing) (% imm1))
220  (jae @no)
221  (subq ($ target::fulltag-cons) (% arg_z))
222  (subq (% imm0) (% arg_z))
223  (shr ($ 1) (% arg_z))
224  (single-value-return)
225  @no
226  (movq ($ nil) (% arg_z))
227  (single-value-return))
228
229#+ppc-target
230(defppclapfunction openmcl-hons:hons-from-index ((index arg_z))
231  "If INDEX is a fixnum between 0 (inclusive) and the current hons space size
232   (exclusive), return a statically allocated CONS cell.  Otherwise, signal
233   an error."
234  (check-nargs 1)
235  (extract-lisptag imm0 index)
236  (cmpri cr0 index 0)
237  (cmpri cr1 imm0 target::tag-fixnum)
238  (ref-global imm0 tenured-area)
239  (unbox-fixnum imm1 arg_z)
240  (ldr imm2 target::area.static-dnodes imm0)
241  (bne cr1 @bad)
242  (cmpr cr2 imm1 imm2)
243  (blt cr0 @bad)
244  (ldr imm2 target::area.static-used imm0)
245  (ldr imm0 target::area.low imm0)
246  (bge cr2 @bad)
247  (add arg_z index index)
248  (add arg_z imm0 arg_z)
249  (la arg_z target::fulltag-cons arg_z)
250  (sub imm0 arg_z imm0)
251  (set-bit-at-index imm2 imm0)
252  (blr)
253  @bad
254  (save-lisp-context)
255  (load-constant arg_x openmcl-hons:invalid-hons-index)
256  (load-constant arg_y :index)
257  (set-nargs 3)
258  (load-constant fname error)
259  (bla .SPjmpsym)
260  (ba .SPpopj))
261
262#+x8664-target
263(defx86lapfunction openmcl-hons:hons-from-index ((index arg_z))
264  "If INDEX is a fixnum between 0 (inclusive) and the current hons space size
265   (exclusive), return a statically allocated CONS cell.  Otherwise, signal
266   an error."
267  (check-nargs 1)
268  (testb ($ x8664::fixnummask) (%b index))
269  (ref-global tenured-area temp0)
270  (jne @bad)
271  (unbox-fixnum index imm1)
272  (rcmpq (% imm1) (@ target::area.static-dnodes (% temp0)))
273  (jae @bad)
274  (shl ($ 1) (% index))
275  (movq (% index) (% imm0))
276  (addq (@ target::area.low (% temp0)) (% index))
277  (addq ($ target::fulltag-cons) (% arg_z))
278  (movq (@ target::area.static-used (% temp0)) (% temp0))
279  (movq (% imm1) (% imm0))
280  (andl ($ 63) (% imm0))
281  (xorb ($ 63) (%b imm0))
282  (shrq ($ 6) (% imm1))
283  (lock)
284  (btsq (% imm0) (@ (% temp0) (% imm1) 8))
285  (single-value-return)
286  @bad
287  (save-simple-frame)
288  (load-constant openmcl-hons:invalid-hons-index arg_x)
289  (load-constant :index arg_y)
290  (call-symbol error 3)
291  (restore-simple-frame)
292  (single-value-return))
293
294
295
296#+ppc-target
297(defppclapfunction openmcl-hons:hons-index-used-p ((index arg_z))
298  "If INDEX is a fixnum between 0 (inclusive) and the current hons space size
299   (exclusive), return a boolean indicating whether the pair is used.
300   Otherwise, signal an error."
301  (check-nargs 1)
302  (extract-lisptag imm0 index)
303  (cmpri cr0 index 0)
304  (cmpri cr1 imm0 target::tag-fixnum)
305  (ref-global imm0 tenured-area)
306  (unbox-fixnum imm1 arg_z)
307  (ldr imm2 target::area.static-dnodes imm0)
308  (bne cr1 @bad)
309  (cmpr cr2 imm1 imm2)
310  (blt cr0 @bad)
311  (ldr imm2 target::area.static-used imm0)
312  (ldr imm0 target::area.low imm0)
313  (bge cr2 @bad)
314  (add imm0 index index)
315  (test-bit-at-index imm2 imm0)
316  (li arg_z nil)
317  (beqlr)
318  (li arg_z t)
319  (blr)
320  @bad
321  (save-lisp-context)
322  (load-constant arg_x openmcl-hons:invalid-hons-index)
323  (load-constant arg_y :index)
324  (set-nargs 3)
325  (load-constant fname error)
326  (bla .SPjmpsym)
327  (ba .SPpopj))
328
329#+x8664-target
330(defx86lapfunction openmcl-hons:hons-index-used-p ((index arg_z))
331  "If INDEX is a fixnum between 0 (inclusive) and the current hons space size
332   (exclusive), return a boolean indicating whether the pair is used.
333   Otherwise, signal an error."
334  (check-nargs 1)
335  (testb ($ x8664::fixnummask) (%b index))
336  (ref-global tenured-area temp0)
337  (jne @bad)
338  (unbox-fixnum index imm1)
339  (rcmpq (% imm1) (@ target::area.static-dnodes (% temp0)))
340  (jae @bad)
341  (movq (@ target::area.static-used (% temp0)) (% temp0))
342  (movq (% imm1) (% imm0))
343  (andl ($ 63) (% imm0))
344  (xorb ($ 63) (%b imm0))
345  (shrq ($ 6) (% imm1))
346  (btq (% imm0) (@ (% temp0) (% imm1) 8))
347  (movl ($ x8664::t-value) (%l imm0))
348  (leaq (@ (- x8664::t-offset) (% imm0)) (% arg_z))
349  (cmovbl (%l imm0) (%l arg_z))
350  (single-value-return)
351  @bad
352  (save-simple-frame)
353  (load-constant openmcl-hons:invalid-hons-index arg_x)
354  (load-constant :index arg_y)
355  (call-symbol error 3)
356  (restore-simple-frame)
357  (single-value-return))
358
359
360#+ppc-target
361(defppclapfunction openmcl-hons:hons-space-ref-car ((index arg_z))
362  "If INDEX is in bounds (non-negative and less than the current hons-space size),
363   return the CAR of the pair at that index.  The return value could be any
364   lisp object, or (HONS-SPACE-DELETED-MARKER).
365   If INDEX is not in bounds, an error is signaled."
366  (check-nargs 1)
367  (extract-lisptag imm0 index)
368  (cmpri cr0 index 0)
369  (cmpri cr1 imm0 target::tag-fixnum)
370  (ref-global imm0 tenured-area)
371  (unbox-fixnum imm1 arg_z)
372  (ldr imm2 target::area.static-dnodes imm0)
373  (bne cr1 @bad)
374  (cmpr cr2 imm1 imm2)
375  (blt cr0 @bad)
376  (ldr imm0 target::area.low imm0)
377  (bge cr2 @bad)
378  (add arg_z index index)
379  (add imm0 imm0 arg_z)
380  (ldr arg_z (+ target::cons.car target::fulltag-cons) imm0)
381  (blr)
382  @bad
383  (save-lisp-context)
384  (load-constant arg_x openmcl-hons:invalid-hons-index)
385  (load-constant arg_y :index)
386  (set-nargs 3)
387  (load-constant fname error)
388  (bla .SPjmpsym)
389  (ba .SPpopj))
390
391#+x8664-target
392(defx86lapfunction openmcl-hons:hons-space-ref-car ((index arg_z))
393  "If INDEX is in bounds (non-negative and less than the current hons-space size),
394   return the CAR of the pair at that index.  The return value could be any
395   lisp object, or (HONS-SPACE-DELETED-MARKER).
396   If INDEX is not in bounds, an error is signaled."
397  (check-nargs 1)
398  (testb ($ x8664::fixnummask) (%b index))
399  (ref-global tenured-area temp0)
400  (jne @bad)
401  (unbox-fixnum index imm1)
402  (rcmpq (% imm1) (@ target::area.static-dnodes (% temp0)))
403  (jae @bad)
404  (shlq ($ 1) (% index))
405  (addq (@ target::area.low (% temp0)) (% arg_z))
406  (movq (@ (+ target::cons.car target::fulltag-cons) (% arg_z)) (% arg_z))
407  (single-value-return)
408  @bad
409  (save-simple-frame)
410  (load-constant openmcl-hons:invalid-hons-index arg_x)
411  (load-constant :index arg_y)
412  (call-symbol error 3)
413  (restore-simple-frame)
414  (single-value-return))
415
416#+ppc-target
417(defppclapfunction openmcl-hons:hons-space-ref-cdr ((index arg_z))
418  "If INDEX is in bounds (non-negative and less than the current hons-space size),
419   return the CAR of the pair at that index.  The return value could be any
420   lisp object, or either (HONS-SPACE-FREE-MARKER) or (HONS-SPACE-DELETED-MARKER).
421   If INDEX is not in bounds, an error is signaled."
422  (check-nargs 1)
423  (extract-lisptag imm0 index)
424  (cmpri cr0 index 0)
425  (cmpri cr1 imm0 target::tag-fixnum)
426  (ref-global imm0 tenured-area)
427  (unbox-fixnum imm1 arg_z)
428  (ldr imm2 target::area.static-dnodes imm0)
429  (bne cr1 @bad)
430  (cmpr cr2 imm1 imm2)
431  (blt cr0 @bad)
432  (ldr imm0 target::area.low imm0)
433  (bge cr2 @bad)
434  (add arg_z index index)
435  (add imm0 imm0 arg_z)
436  (ldr arg_z (+ target::cons.cdr target::fulltag-cons) imm0)
437  (blr)
438  @bad
439  (save-lisp-context)
440  (load-constant arg_x openmcl-hons:invalid-hons-index)
441  (load-constant arg_y :index)
442  (set-nargs 3)
443  (load-constant fname error)
444  (bla .SPjmpsym)
445  (ba .SPpopj))
446
447#+x8664-target
448(defx86lapfunction openmcl-hons:hons-space-ref-cdr ((index arg_z))
449  "If INDEX is in bounds (non-negative and less than the current hons-space size),
450   return the CDR of the pair at that index.  The return value could be any
451   lisp object, or (HONS-SPACE-DELETED-MARKER).
452   If INDEX is not in bounds, an error is signaled."
453  (check-nargs 1)
454  (testb ($ x8664::fixnummask) (%b index))
455  (ref-global tenured-area temp0)
456  (jne @bad)
457  (unbox-fixnum index imm1)
458  (rcmpq (% imm1) (@ target::area.static-dnodes (% temp0)))
459  (jae @bad)
460  (shlq ($ 1) (% index))
461  (addq (@ target::area.low (% temp0)) (% arg_z))
462  (movq (@ (+ target::cons.cdr target::fulltag-cons) (% arg_z)) (% arg_z))
463  (single-value-return)
464  @bad
465  (save-simple-frame)
466  (load-constant openmcl-hons:invalid-hons-index arg_x)
467  (load-constant :index arg_y)
468  (call-symbol error 3)
469  (restore-simple-frame)
470  (single-value-return))
471
472
473
474
475(defun openmcl-hons:hons-space-cons (index new-car new-cdr)
476  "Return a CONS cell with the specified NEW-CAR and NEW-CDR,
477   allocated at the INDEXth pair in hons space."
478  (let* ((hons (openmcl-hons:hons-from-index index)))
479    (setf (car hons) new-car
480          (cdr hons) new-cdr)
481    hons))
482
483;;; We might have multiple (logical) tables in hons space, and
484;;; would probably like to know how many pairs had been deleted
485;;; from each table.  (How to express that to the GC in some
486;;; way that would allow it to efficiently track this is an
487;;; open question.)  For now, the GC just maintains a global
488;;; count of static pairs that it's deleted.
489(defun openmcl-hons:deleted-hons-count ()
490  "Returns the total number of pairs in hons space that have
491   been deleted by the GC."
492  (%get-kernel-global 'deleted-static-pairs))
493
494(defun (setf openmcl-hons:deleted-hons-count) (new)
495  (check-type new (and fixnum unsigned-byte))
496  (%set-kernel-global 'deleted-static-pairs new))
497
498(provide "HASH-CONS")
Note: See TracBrowser for help on using the repository browser.