Changeset 3501


Ignore:
Timestamp:
Feb 27, 2006, 3:31:25 AM (14 years ago)
Author:
gb
Message:

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

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/examples/hons-example.lisp

    r3264 r3501  
    5555            (hons-table-max ht))))
    5656
    57 
    58 ;;; Since it may be prohibitively expensive to grow or rehash a
    59 ;;; hons table in place, we just allocate a new one (or at least
    60 ;;; try to) whenever the current one fills up.  We have to
    61 ;;; search through all known hons tables when doing a lookup,
    62 ;;; but allocate in the most recent (or "active") table, which
    63 ;;; is in the CAR of *ALL-HONS-TABLES*.
     57;;; The "active" HONS table is the CAR of this list.
    6458(defparameter *all-hons-tables* ()
    6559  "A list of all hons tables, maintained in reverse order of creation (e.g., the CAR of this list is the most recently created.)")
    6660
    67 (defparameter *hons-table-max-full-ratio* (/ 4 5)
     61(defparameter *hons-table-max-full-ratio* .85
    6862  "Controls how full a hons table can get.")
    6963
     
    9589      (error "Couldn't increase hons space size by ~d pairs" size))))
    9690
     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
    9797;;; Exactly what types of objects can go in the CAR or CDR of
    9898;;; a HONS table is application dependent, but it's reasonable
    9999;;; to insist that all CONSes are HONSes.
     100
     101
    100102(defun hash-pair-for-honsing (car cdr)
    101103  ;; This often calls CCL::%%EQLHASH, which is (as one might
     
    115117                ((or bignum single-float double-float)
    116118                 (ccl::%%eqlhash thing))
    117                 (null (ccl::%%eqlhash thing))
    118                 (symbol (let* ((string (symbol-name thing)))
    119                           (ccl::string-hash string 0 (length string))))
    120                 (string (ccl::string-hash thing 0 (length thing)))
     119                (null target::nil-value)
     120                (symbol (hons-hash-string (symbol-name thing)))
     121                (simple-string (hons-hash-string thing))
    121122                ((complex rational) (ccl::%%eqlhash thing))))
    122123            most-positive-fixnum)))
    123     (or (let* ((honsp (openmcl-hons:honsp cdr)))
    124           (if honsp (the fixnum (1+ (the fixnum honsp)))))
    125         (the fixnum
    126           (logxor (the fixnum (hash-for-honsing car))
    127                   (the fixnum (hash-for-honsing cdr)))))))
     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
    128131
    129132(defun hons-table-get (ht hash car cdr)
     
    131134Returns a CONS if a match is found, a fixnum index otherwise."
    132135  (declare (fixnum hash) (optimize (speed 3)))
     136  (incf *hons-probes*)
    133137  (do* ((size (hons-table-size ht))
    134138        (start (hons-table-start-index ht))
    135139        (end (+ start size))
    136         (idx (+ start (the fixnum (ccl::fast-mod hash size))) (+ idx (ash size -2)))
     140        (idx (+ start (the fixnum (ccl::fast-mod hash size))) (+ idx 1))
    137141        (first-deleted-index nil))
    138142       ()
     
    140144    (if (>= idx end)
    141145      (decf idx size))
    142     (let* ((used (openmcl-hons:hons-index-used-p idx))
    143            (hcar (openmcl-hons:hons-space-ref-car idx))
     146    (let* ((hcar (openmcl-hons:hons-space-ref-car idx))
    144147           (hcdr (openmcl-hons:hons-space-ref-cdr idx)))
    145       (cond ((and used (eql hcar car) (eql hcdr cdr))
     148      (cond ((and (eql hcar car) (eql hcdr cdr))
    146149             (return (openmcl-hons:hons-from-index idx)))
    147             ((not used)
    148              (if (eq car (openmcl-hons:hons-space-deleted-marker))
     150            (t
     151             (if (eq hcar (openmcl-hons:hons-space-deleted-marker))
    149152               (unless first-deleted-index
    150153                 (setq first-deleted-index idx))
    151                (return (or 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*))))
    152157
    153158
     
    164169(defun hons (car cdr)
    165170  (let* ((tables *all-hons-tables*)
    166          (active-table (pop tables))
    167          (h nil)
    168          (active-idx nil)
    169          (hash (hash-pair-for-honsing car cdr)))
     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)))
    170176    (declare (fixnum hash))
    171     (if (not active-table)
    172       (setq active-table
    173             (make-hons-table *initial-hons-table-size*)))
    174     (or (progn
    175           (setq h (hons-table-get active-table hash car cdr))
    176           (if (consp h)
    177             h
    178             (progn
    179               (setq active-idx h)
    180               nil)))
    181         (let* ((cdr-is-hons (openmcl-hons:honsp cdr)))
    182           (dolist (table tables)
    183             (when (and cdr-is-hons
    184                        (>= cdr-is-hons (hons-table-end-index table)))
    185               (return))
    186             (when (typep (setq h (hons-table-get table hash car cdr)) 'cons)
    187               (return h))))
    188         (when (< (hons-table-used active-table)
    189                  (hons-table-max active-table))
    190           (incf (hons-table-used active-table))
    191           (openmcl-hons:hons-space-cons active-idx car cdr))
    192         (progn
    193           (let* ((new (make-hons-table *secondary-hons-table-size*))
    194                  (new-idx (hons-table-get new hash car cdr)))
    195             (incf (hons-table-used new))
    196             (openmcl-hons:hons-space-cons new-idx car cdr))))))
     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
    197184
    198185
Note: See TracChangeset for help on using the changeset viewer.