source: trunk/source/examples/hons-example.lisp @ 8441

Last change on this file since 8441 was 3501, checked in by gb, 14 years ago

Still needs work, but not quite so brain-dead.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 8.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(in-package "CL-USER")
18
19;;; A sample HONS (hash-consing) implementation, based on the
20;;; primitives defined in "ccl:library;hash-cons.lisp".
21
22(defun largest-prime-less-than-or-equal-to (n)
23  (flet ((primep (n)
24           (or (eql n 1)
25               (eql n 2)
26               (and (oddp n)
27                    (let* ((max (isqrt n)))
28                      (do* ((i 3 (+ i 2)))
29                           ((> i max) t)
30                        (when (zerop (mod n i))
31                          (return nil))))))))
32    (if (primep n)
33      n
34      (do* ((m (if (oddp n) (- n 2) (- n 1)) (- m 2)))
35           ((primep m) m)))))
36
37
38;;; A "hons-table" just represents a range of indices in a
39;;; static memory region dedicated to hash-consing (and
40;;; a little information about the contents of that region.)
41(defstruct (hons-table (:constructor %make-hons-table))
42  start-index                           ;lower inclusive index
43  end-index                             ;upper exclusive index
44  size                                  ;(<= size (- end-index start-index))
45  max                                   ;maximum "full" point
46  (used 0)                              ;current number of used pairs
47  )
48
49(defmethod print-object ((ht hons-table) stream)
50  (print-unreadable-object (ht stream :type t :identity t)
51    (format stream "indices ~d-~d, used ~d/~d"
52            (hons-table-start-index ht)
53            (hons-table-end-index ht)
54            (hons-table-used ht)
55            (hons-table-max ht))))
56
57;;; The "active" HONS table is the CAR of this list.
58(defparameter *all-hons-tables* ()
59  "A list of all hons tables, maintained in reverse order of creation (e.g., the CAR of this list is the most recently created.)")
60
61(defparameter *hons-table-max-full-ratio* .85
62  "Controls how full a hons table can get.")
63
64;;; Try to allocate a new HONS table, which describes a newly
65;;; allocated range of indices in HONS space.  If successful,
66;;; that new table gets pushed onto the front of *ALL-HONS-TABLES*
67;;; and returned.
68(defun make-hons-table (size &optional (max-full-ratio
69                                        *hons-table-max-full-ratio*))
70  (check-type size (and fixnum unsigned-byte))
71  (setq size (largest-prime-less-than-or-equal-to size))
72  (let* ((current (openmcl-hons:hons-space-size))
73         (new (setf (openmcl-hons:hons-space-size)
74                    (+ current (the fixnum size)))))
75    (declare (fixnum current new))
76    (if (>= (- new current) size)
77      (let* ((table (%make-hons-table :start-index current
78                                      :end-index new
79                                      :size size
80                                      :max (floor (* size max-full-ratio)))))
81        (push table *all-hons-tables*)
82        table)
83      ;; As of 12/30/05, there's a slight possibility that
84      ;; #'(setf opencl-hons:hons-space-size) can fail
85      ;; even though address-space/memory are available.
86      ;; (The problem has to do with the way that CCL:WITHOUT-GCING
87      ;; works; if the GC is disabled, we can't move things around,
88      ;; but there isn't currently an easy way to detect that.)
89      (error "Couldn't increase hons space size by ~d pairs" size))))
90
91(defun hons-hash-string (s)
92  (let* ((h 0))
93    (declare (fixnum h))
94    (dotimes (i (length s) (logand h most-positive-fixnum))
95      (setq h (+ (the fixnum (* 4999 h)) (the fixnum (ccl::%scharcode s i)))))))
96
97;;; Exactly what types of objects can go in the CAR or CDR of
98;;; a HONS table is application dependent, but it's reasonable
99;;; to insist that all CONSes are HONSes.
100
101
102(defun hash-pair-for-honsing (car cdr)
103  ;; This often calls CCL::%%EQLHASH, which is (as one might
104  ;; assume) a primitive used with EQL hash tables.  It tries
105  ;; to "scramble the bits" a little, so that "related" keys
106  ;; (like numerically adjacent integers) hash to unrelated
107  ;; values.
108  (flet ((hash-for-honsing (thing)
109           (logand
110            (the fixnum
111              (etypecase thing
112                (cons (let* ((idx (openmcl-hons::honsp thing)))
113                        (if idx
114                          (ccl::%%eqlhash idx)
115                          (error "~s is not HONSP." thing))))
116                (fixnum (ccl::%%eqlhash thing))
117                ((or bignum single-float double-float)
118                 (ccl::%%eqlhash thing))
119                (null target::nil-value)
120                (symbol (hons-hash-string (symbol-name thing)))
121                (simple-string (hons-hash-string thing))
122                ((complex rational) (ccl::%%eqlhash thing))))
123            most-positive-fixnum)))
124     (the fixnum
125       (+ (the fixnum (* 37 (the fixnum (hash-for-honsing car))))
126          (the fixnum (* 33 (the fixnum (hash-for-honsing cdr))))))))
127
128(defparameter *hons-probes* 0)
129(defparameter *hons-secondary-probes* 0)
130
131
132(defun hons-table-get (ht hash car cdr)
133  "Tries to find a HONS with matching (EQL) CAR and CDR in the hash table HT.
134Returns a CONS if a match is found, a fixnum index otherwise."
135  (declare (fixnum hash) (optimize (speed 3)))
136  (incf *hons-probes*)
137  (do* ((size (hons-table-size ht))
138        (start (hons-table-start-index ht))
139        (end (+ start size))
140        (idx (+ start (the fixnum (ccl::fast-mod hash size))) (+ idx 1))
141        (first-deleted-index nil))
142       ()
143    (declare (fixnum start end size idx))
144    (if (>= idx end)
145      (decf idx size))
146    (let* ((hcar (openmcl-hons:hons-space-ref-car idx))
147           (hcdr (openmcl-hons:hons-space-ref-cdr idx)))
148      (cond ((and  (eql hcar car) (eql hcdr cdr))
149             (return (openmcl-hons:hons-from-index idx)))
150            (t
151             (if (eq hcar (openmcl-hons:hons-space-deleted-marker))
152               (unless first-deleted-index
153                 (setq first-deleted-index idx))
154               (if (eq hcar (openmcl-hons:hons-space-free-marker))
155                 (return (or first-deleted-index idx))))))
156      (incf *hons-secondary-probes*))))
157
158
159;;; These values are entirely arbitrary.
160
161(defparameter *initial-hons-table-size* (ash 100 20)
162  "The number of pairs to allocate in the initially allocated hons table.")
163
164(defparameter *secondary-hons-table-size* (ash 25 20)
165  "The number of pairs to allocate in subsequently allocated hons tables.")
166
167;;; Find HONS (a statically allocated CONS cell) with matching CAR and
168;;; CDR, or create a new one.
169(defun hons (car cdr)
170  (let* ((tables *all-hons-tables*)
171         (active-table (if tables
172                         (car tables)
173                         (make-hons-table *initial-hons-table-size*)))
174         (hash (hash-pair-for-honsing car cdr))
175         (h (hons-table-get active-table hash car cdr)))
176    (declare (fixnum hash))
177    (cond ((consp h) h)
178          ((< (hons-table-used active-table)
179              (hons-table-max active-table))
180           (incf (hons-table-used active-table))
181           (openmcl-hons:hons-space-cons h car cdr))
182          (t (error "Active hons table is full.")))))
183
184
185
186;;; Some utilities.
187
188(defun discard-active-hons-table ()
189  (let* ((table (pop *all-hons-tables*)))
190    (when table
191      (setf (openmcl-hons:hons-space-size) (hons-table-start-index table)
192            (hons-table-start-index table) nil)
193      t)))
194     
195           
196(defun discard-all-hons-tables ()
197  (dolist (table *all-hons-tables*)
198    ;; Invalidate the table.
199    (setf (hons-table-start-index table) nil))
200  (setq *all-hons-tables* nil)
201  (setf (openmcl-hons:hons-space-size) 0)
202  t)
203
204#||
205
206(defvar *test-var*)
207
208(defun test (n)
209  (setq *test-var* nil)
210  (loop for i from 1 to n do
211        (print i)
212        (loop for i from 1 to 1000000 do
213              (setq *test-var* (hons i *test-var*)))))
214
215
216||#
217
218
219
220
221               
Note: See TracBrowser for help on using the repository browser.