source: branches/working-0710/ccl/library/hash-cons.lisp @ 7419

Last change on this file since 7419 was 7419, checked in by gb, 12 years ago

File is obsolete; conditionalize it out so that we don't have bootstrapping
problems.

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