hons-raw

(defun hl-mht-fn
  (&key (test 'eql)
    (size '60)
    (rehash-size '1.5)
    (rehash-threshold '0.7)
    (weak 'nil)
    (shared 'nil)
    (lock-free 'nil))
  (declare (ignorable shared weak lock-free))
  (cond ((eq shared :default) (make-hash-table :test test
        :size size
        :rehash-size rehash-size
        :rehash-threshold rehash-threshold
        :weakness weak))
    (t (make-hash-table :test test
        :size size
        :rehash-size rehash-size
        :rehash-threshold rehash-threshold
        :weakness weak))))

(defun hl-cache-set
  (key val cache)
  (declare (type hl-cache cache))
  (let ((table (hl-cache-table cache)) (count (hl-cache-count cache)))
    (cond ((>= (the fixnum count) (the fixnum hl-cache-table-cutoff)) (clrhash table)
        (setf (hl-cache-count cache) 1))
      (t (setf (hl-cache-count cache)
          (the fixnum (+ 1 (the fixnum count))))))
    (setf (gethash key table) val)))

(defun hl-cache-get
  (key cache)
  (declare (type hl-cache cache))
  (let* ((table (hl-cache-table cache)) (val (gethash key table)))
    (if val
      (mv t val)
      (mv nil nil))))

(defun hl-cache-clear
  (cache)
  (declare (type hl-cache cache))
  (progn (clrhash (hl-cache-table cache))
    (setf (hl-cache-count cache) 0)))

(defun hl-initialize-faltable-table
  (fal-ht-size)
  (let ((table (hl-mht :test (function eq) :size (max 100 fal-ht-size) :weak :key)))
    table))

(defun hl-faltable-init
  (&key (size *hl-hspace-fal-ht-default-size*))
  (hl-faltable-init-raw :table (hl-initialize-faltable-table size)))

(defun hl-hspace-init
  (&key (str-ht-size *hl-hspace-str-ht-default-size*)
    (nil-ht-size *hl-ctables-nil-ht-default-size*)
    (cdr-ht-size *hl-ctables-cdr-ht-default-size*)
    (cdr-ht-eql-size *hl-ctables-cdr-ht-eql-default-size*)
    (addr-ht-size *hl-hspace-addr-ht-default-size*)
    (sbits-size *hl-hspace-sbits-default-size*)
    (other-ht-size *hl-hspace-other-ht-default-size*)
    (fal-ht-size *hl-hspace-fal-ht-default-size*)
    (persist-ht-size *hl-hspace-persist-ht-default-size*))
  (declare (ignore addr-ht-size sbits-size other-ht-size))
  (hl-hspace-init-raw :str-ht (hl-mht :test (function equal) :size (max 100 str-ht-size))
    :ctables (make-hl-ctables :nil-ht (hl-mht :test (function eql) :size (max 100 nil-ht-size))
      :cdr-ht (hl-mht :test (function eq) :size (max 100 cdr-ht-size))
      :cdr-ht-eql (hl-mht :test (function eql) :size (max 100 cdr-ht-eql-size)))
    :norm-cache (make-hl-cache)
    :faltable (hl-faltable-init :size fal-ht-size)
    :persist-ht (hl-mht :test (function eq) :size (max 100 persist-ht-size))))

(defun hl-hspace-honsp
  (x hs)
  (let* ((a (car x)) (b (cdr x))
      (ctables (hl-hspace-ctables hs))
      (hons-set (hl-hspace-find-flex-alist-for-cdr b ctables))
      (entry (hl-flex-assoc a hons-set)))
    (eq x entry)))

(defun hl-hspace-honsp-wrapper
  (x)
  (declare (special *default-hs*))
  (hl-hspace-honsp x *default-hs*))

(defun hl-hspace-faltable-wrapper
  nil
  (declare (special *default-hs*))
  (hl-hspace-faltable *default-hs*))

(defun hl-hspace-normedp
  (x hs)
  (declare (type hl-hspace hs))
  (cond ((consp x) (hl-hspace-honsp x hs))
    ((stringp x) (let* ((str-ht (hl-hspace-str-ht hs)) (entry (gethash x str-ht)))
        (and entry (eq x entry))))
    (t t)))

(defun hl-hspace-normedp-wrapper
  (x)
  (declare (special *default-hs*))
  (hl-hspace-normedp x *default-hs*))

(defun hl-hspace-hons-equal-lite
  (x y hs)
  (declare (type hl-hspace hs))
  (cond ((eq x y) t)
    ((and (consp x)
       (consp y)
       (hl-hspace-honsp x hs)
       (hl-hspace-honsp y hs)) nil)
    (t (equal x y))))

(defun hl-hspace-hons-equal-1
  (x y hs)
  (declare (type hl-hspace hs))
  (cond ((eq x y) t)
    ((consp x) (and (consp y)
        (not (hl-hspace-honsp y hs))
        (hl-hspace-hons-equal-1 (car x) (car y) hs)
        (hl-hspace-hons-equal-1 (cdr x) (cdr y) hs)))
    ((consp y) nil)
    (t (equal x y))))

(defun hl-hspace-hons-equal
  (x y hs)
  (declare (type hl-hspace hs))
  (cond ((eq x y) t)
    ((consp x) (and (consp y)
        (cond ((hl-hspace-honsp x hs) (cond ((hl-hspace-honsp y hs) nil)
              (t (and (hl-hspace-hons-equal-1 (car x) (car y) hs)
                  (hl-hspace-hons-equal-1 (cdr x) (cdr y) hs)))))
          ((hl-hspace-honsp y hs) (and (hl-hspace-hons-equal-1 (car y) (car x) hs)
              (hl-hspace-hons-equal-1 (cdr y) (cdr x) hs)))
          (t (and (hl-hspace-hons-equal (car x) (car y) hs)
              (hl-hspace-hons-equal (cdr x) (cdr y) hs))))))
    ((consp y) nil)
    (t (equal x y))))

(defun hl-hspace-norm-atom
  (x hs)
  (cond ((typep x 'array) (let* ((str-ht (hl-hspace-str-ht hs)) (entry (gethash x str-ht)))
        (or entry (setf (gethash x str-ht) x))))
    (t x)))

(defun hl-hspace-hons-normed
  (a b hint hs)
  (let ((ctables (hl-hspace-ctables hs)))
    (if (eq b nil)
      (let* ((nil-ht (hl-ctables-nil-ht ctables)) (entry (gethash a nil-ht)))
        (or entry
          (let ((new-cons (if (and (consp hint) (eq (car hint) a) (eq (cdr hint) b))
                 hint
                 (cons a b))))
            (setf (gethash a nil-ht) new-cons))))
      (let* ((main-table (if (or (consp b) (symbolp b) (typep b 'array))
             (hl-ctables-cdr-ht ctables)
             (hl-ctables-cdr-ht-eql ctables))) (flex-alist (gethash b main-table))
          (entry (hl-flex-assoc a flex-alist)))
        (or entry
          (let* ((was-alistp (listp flex-alist)) (new-cons (if (and (consp hint) (eq (car hint) a) (eq (cdr hint) b))
                  hint
                  (cons a b)))
              (new-flex-alist (hl-flex-acons new-cons flex-alist)))
            (when was-alistp
              (setf (gethash b main-table) new-flex-alist))
            new-cons))))))

(defun hl-hspace-norm-aux
  (x cache hs)
  (declare (type hl-cache cache)
    (type hl-hspace hs))
  (cond ((atom x) (hl-hspace-norm-atom x hs))
    ((hl-hspace-honsp x hs) x)
    (t (hl-hspace-norm-aux-consp x cache hs))))

(defun hl-hspace-norm-expensive
  (x hs)
  (let ((cache (hl-hspace-norm-cache hs)))
    (hl-hspace-norm-aux-consp x cache hs)))

(defun hl-hspace-norm
  (x hs)
  (cond ((atom x) (hl-hspace-norm-atom x hs))
    ((hl-hspace-honsp x hs) x)
    (t (hl-hspace-norm-expensive x hs))))

(defun hl-hspace-persistent-norm
  (x hs)
  (let ((x (hl-hspace-norm x hs)))
    (when (consp x)
      (let ((persist-ht (hl-hspace-persist-ht hs)))
        (setf (gethash x persist-ht) t)))
    x))

(defun get-slow-alist-action
  (stolen-p state)
  (and (if stolen-p
      (not *defeat-slow-alist-action*)
      (not (eq *defeat-slow-alist-action* t)))
    (let* ((alist (table-alist 'hons (w state))) (warning (hons-assoc-equal 'slow-alist-warning alist)))
      (and (consp warning) (cdr warning)))))

(defun hl-slow-alist-warning
  (name)
  (let ((action (get-slow-alist-action nil *the-live-state*)))
    (when action
      (let* ((wrld (w *the-live-state*)) (path (global-val 'include-book-path wrld))
          (book-string (if path
              (concatenate 'string
                "
This violation occurred while attempting to include the book:
"
                (book-name-to-filename (car path) wrld 'slow-alist-warning))
              ""))
          (normal-string "
*****************************************************************
Fast alist discipline violated in ~a.
See :DOC slow-alist-warning to suppress or break on this warning.~a
*****************************************************************~%"))
        (format *error-output* normal-string name book-string))
      (when (eq action :break)
        (format *error-output*
          "
To avoid the following break and get only the above warning:~%  ~s~%"
          '(set-slow-alist-action :warning))
        (break$)))))

(defun hl-faltable-maphash
  (f faltable)
  (declare (type hl-faltable faltable))
  (let ((slot1 (hl-faltable-slot1 faltable)) (slot2 (hl-faltable-slot2 faltable))
      (table (hl-faltable-table faltable)))
    (unless (hl-falslot-uniquep slot1)
      (remhash (hl-falslot-key slot1) table)
      (setf (hl-falslot-uniquep slot1) t))
    (unless (hl-falslot-uniquep slot2)
      (remhash (hl-falslot-key slot2) table)
      (setf (hl-falslot-uniquep slot2) t))
    (when (hl-falslot-key slot1)
      (funcall f (hl-falslot-key slot1) (hl-falslot-val slot1)))
    (when (hl-falslot-key slot2)
      (funcall f (hl-falslot-key slot2) (hl-falslot-val slot2)))
    (maphash f table)))

(defun hl-faltable-load-empty-slot
  (alist slot faltable)
  (declare (type hl-faltable faltable)
    (type hl-falslot slot))
  (let* ((table (hl-faltable-table faltable)) (val (gethash alist table)))
    (setf (hl-falslot-uniquep slot) nil)
    (setf (hl-falslot-val slot) val)
    (setf (hl-falslot-key slot) (and val alist))
    (remhash alist table)
    (setf (hl-falslot-uniquep slot) t)))

(defun hl-faltable-eject
  (slot faltable)
  (declare (type hl-faltable faltable)
    (type hl-falslot slot))
  (let ((key (hl-falslot-key slot)))
    (when key
      (setf (hl-falslot-uniquep slot) nil)
      (setf (gethash key (hl-faltable-table faltable))
        (hl-falslot-val slot))
      (setf (hl-falslot-key slot) nil)
      (setf (hl-falslot-val slot) nil)
      (setf (hl-falslot-uniquep slot) t))))

(defun hl-faltable-get-free-slot
  (faltable)
  (declare (type hl-faltable faltable))
  (let* ((eject1 (hl-faltable-eject1 faltable)) (loser (if eject1
          (hl-faltable-slot1 faltable)
          (hl-faltable-slot2 faltable))))
    (hl-faltable-eject loser faltable)
    (setf (hl-faltable-eject1 faltable) (not eject1))
    loser))

(defun hl-faltable-slot-lookup
  (alist faltable)
  (declare (type hl-faltable faltable))
  (let* ((slot1 (hl-faltable-slot1 faltable)) (slot (if (eq alist (hl-falslot-key slot1))
          slot1
          (let ((slot2 (hl-faltable-slot2 faltable)))
            (if (eq alist (hl-falslot-key slot2))
              slot2
              nil)))))
    (unless slot (return-from hl-faltable-slot-lookup nil))
    (unless (hl-falslot-uniquep slot)
      (remhash alist (hl-faltable-table faltable))
      (setf (hl-falslot-uniquep slot) t))
    (setf (hl-faltable-eject1 faltable) (not (eq slot slot1)))
    slot))

(defun hl-faltable-general-lookup
  (alist faltable)
  (declare (type hl-faltable faltable))
  (or (hl-faltable-slot-lookup alist faltable)
    (let ((slot (hl-faltable-get-free-slot faltable)))
      (hl-faltable-load-empty-slot alist slot faltable)
      slot)))

(defun hl-faltable-remove
  (alist faltable)
  (declare (type hl-faltable faltable))
  (let ((slot (hl-faltable-slot-lookup alist faltable)))
    (cond (slot (setf (hl-falslot-key slot) nil)
        (setf (hl-falslot-val slot) nil)
        (setf (hl-faltable-eject1 faltable)
          (not (hl-faltable-eject1 faltable))))
      (t (remhash alist (hl-faltable-table faltable))))))

(defun hl-hspace-fast-alist-free
  (alist hs)
  (declare (type hl-hspace hs))
  (cond ((atom alist) alist)
    (t (hl-faltable-remove alist (hl-hspace-faltable hs)) alist)))

(defun hl-hspace-hons-get
  (key alist hs)
  (declare (type hl-hspace hs))
  (if (atom alist)
    nil
    (let* ((faltable (hl-hspace-faltable hs)) (slot (hl-faltable-general-lookup alist faltable))
        (val (hl-falslot-val slot)))
      (if val
        (values (gethash (hl-hspace-norm key hs) val))
        (progn (hl-slow-alist-warning 'hons-get)
          (hons-assoc-equal key alist))))))

(defun hl-hspace-hons-acons
  (key value alist hs)
  (declare (type hl-hspace hs))
  (let* ((key (hl-hspace-norm key hs)) (entry (cons key value))
      (ans (cons entry alist))
      (faltable (hl-hspace-faltable hs)))
    (if (atom alist)
      (let* ((size (if (and (typep alist 'fixnum) (<= 60 (the fixnum alist)))
             alist
             60)) (tab (hl-mht :size size))
          (slot (hl-faltable-get-free-slot faltable)))
        (setf (gethash key (the hash-table tab)) entry)
        (setf (hl-falslot-val slot) tab)
        (setf (hl-falslot-key slot) ans))
      (let* ((slot (hl-faltable-general-lookup alist faltable)) (val (hl-falslot-val slot)))
        (if (not val)
          (hl-slow-alist-warning 'hons-acons)
          (progn (setf (hl-falslot-key slot) nil)
            (setf (gethash key (the hash-table val)) entry)
            (setf (hl-falslot-key slot) ans)))))
    ans))

(defun hl-alist-stolen-warning
  (name)
  (let ((action (get-slow-alist-action t *the-live-state*)))
    (when (and action (not (eq *defeat-slow-alist-action* 'stolen)))
      (let* ((wrld (w *the-live-state*)) (path (global-val 'include-book-path wrld)))
        (format *error-output*
          "
*****************************************************************
Fast alist stolen by ~a.
See the documentation for fast alists for how to fix the problem,
or suppress this warning message with:~%  ~a~a
****************************************************************~%"
          name
          '(set-slow-alist-action nil)
          (if path
            (concatenate 'string
              "
This violation occurred while attempting to include the book:
"
              (book-name-to-filename (car path)
                wrld
                'hl-alist-stolen-warning))
            "")))
      (when (eq action :break)
        (format *error-output*
          "
To avoid the following break and get only the above warning:~%  ~s~%"
          '(set-slow-alist-action :warning))
        (break$)))))

(defun hl-hspace-hons-acons!
  (key value alist hs)
  (declare (type hl-hspace hs))
  (let* ((key (hl-hspace-norm key hs)) (entry (hl-hspace-hons key value hs))
      (ans (hl-hspace-hons entry alist hs))
      (faltable (hl-hspace-faltable hs)))
    (let ((slot (hl-faltable-general-lookup ans faltable)))
      (when (hl-falslot-key slot)
        (hl-alist-stolen-warning 'hons-acons!)
        (setf (hl-falslot-key slot) nil)
        (setf (hl-falslot-val slot) nil)))
    (if (atom alist)
      (let* ((size (if (and (typep alist 'fixnum) (<= 60 (the fixnum alist)))
             alist
             60)) (tab (hl-mht :size size))
          (slot (hl-faltable-get-free-slot faltable)))
        (setf (gethash key (the hash-table tab)) entry)
        (setf (hl-falslot-val slot) tab)
        (setf (hl-falslot-key slot) ans))
      (let* ((slot (hl-faltable-general-lookup alist faltable)) (val (hl-falslot-val slot)))
        (if (not val)
          (hl-slow-alist-warning 'hons-acons)
          (progn (setf (hl-falslot-key slot) nil)
            (setf (gethash key (the hash-table val)) entry)
            (setf (hl-falslot-key slot) ans)))))
    ans))

(defun hl-alist-longest-normed-tail
  (alist hs)
  (declare (type hl-hspace hs))
  (let ((ok-tail alist))
    (loop for
      tail
      on
      alist
      while
      (consp tail)
      do
      (let ((pair (car tail)))
        (when (and (consp pair) (not (hl-hspace-normedp (car pair) hs)))
          (setq ok-tail (cdr tail)))))
    ok-tail))

(defun hl-make-fast-norm-keys
  (alist tail hs)
  (declare (type hl-hspace hs))
  (if (eq tail alist)
    alist
    (let* ((first-cons (list nil)) (last-cons first-cons))
      (loop for
        rest
        on
        alist
        while
        (and (consp rest) (not (eq rest tail)))
        do
        (let* ((pair (car rest)) (cons (list (if (and (consp pair) (not (hl-hspace-normedp (car pair) hs)))
                  (cons (hl-hspace-norm (car pair) hs) (cdr pair))
                  pair))))
          (setf (cdr last-cons) cons)
          (setq last-cons cons)))
      (setf (cdr last-cons) tail)
      (cdr first-cons))))

(defun hl-make-fast-alist-put-pairs
  (alist ht)
  (declare (type hash-table ht))
  (loop for
    rest
    on
    alist
    while
    (consp rest)
    do
    (let ((pair (car rest)))
      (when (and (consp pair) (not (gethash (car pair) ht)))
        (setf (gethash (car pair) ht) pair)))))

(defun hl-hspace-make-fast-alist
  (alist hs)
  (declare (type hl-hspace hs))
  (if (atom alist)
    alist
    (let* ((faltable (hl-hspace-faltable hs)) (slot (hl-faltable-general-lookup alist faltable))
        (alist-table (hl-falslot-val slot)))
      (if alist-table
        alist
        (let* ((tail (hl-alist-longest-normed-tail alist hs)) (alist (hl-make-fast-norm-keys alist tail hs)))
          (setq alist-table
            (hl-mht :size (max 60 (ash (len alist) -3))))
          (hl-make-fast-alist-put-pairs alist alist-table)
          (setf (hl-falslot-val slot) alist-table)
          (setf (hl-falslot-key slot) alist)
          alist)))))

(defun hl-fast-alist-fork-aux-really-slow
  (alist ans honsp hs)
  (cond ((atom alist) ans)
    ((atom (car alist)) (hl-fast-alist-fork-aux-really-slow (cdr alist)
        ans
        honsp
        hs))
    (t (let* ((key (hl-hspace-norm (caar alist) hs)) (entry (hons-assoc-equal key ans)))
        (unless entry
          (if honsp
            (progn (setq entry (hl-hspace-hons key (cdar alist) hs))
              (setq ans (hl-hspace-hons entry ans hs)))
            (progn (setq entry (cons key (cdar alist)))
              (setq ans (cons entry ans)))))
        (hl-fast-alist-fork-aux-really-slow (cdr alist)
          ans
          honsp
          hs)))))

(defun hl-fast-alist-fork-aux-slow
  (alist ans table honsp hs)
  (declare (type hl-hspace hs)
    (type hash-table table))
  (cond ((atom alist) ans)
    ((atom (car alist)) (hl-fast-alist-fork-aux-slow (cdr alist) ans table honsp hs))
    (t (let* ((key (hl-hspace-norm (caar alist) hs)) (entry (gethash key table)))
        (unless entry
          (if honsp
            (progn (setq entry (hl-hspace-hons key (cdar alist) hs))
              (setq ans (hl-hspace-hons entry ans hs))
              (setf (gethash key table) entry))
            (progn (setq entry (cons key (cdar alist)))
              (setq ans (cons entry ans))
              (setf (gethash key table) entry))))
        (hl-fast-alist-fork-aux-slow (cdr alist) ans table honsp hs)))))

(defun hl-fast-alist-fork-aux-fast
  (alist ans table honsp hs)
  (declare (type hl-hspace hs)
    (type hash-table table))
  (cond ((atom alist) ans)
    ((atom (car alist)) (hl-fast-alist-fork-aux-fast (cdr alist) ans table honsp hs))
    (t (let* ((key (caar alist)) (entry (gethash key table)))
        (unless entry
          (if honsp
            (progn (setq entry (hl-hspace-hons key (cdar alist) hs))
              (setq ans (hl-hspace-hons entry ans hs))
              (setf (gethash key table) entry))
            (progn (setq entry (car alist))
              (setq ans (cons entry ans))
              (setf (gethash key table) entry))))
        (hl-fast-alist-fork-aux-fast (cdr alist) ans table honsp hs)))))

(defun hl-hspace-fast-alist-fork
  (alist ans honsp hs)
  (declare (type hl-hspace hs))
  (if (atom alist)
    ans
    (let* ((faltable (hl-hspace-faltable hs)) (alist-table (let ((slot (hl-faltable-general-lookup alist faltable)))
            (hl-falslot-val slot)))
        (ans-slot (if (atom ans)
            (hl-faltable-get-free-slot faltable)
            (hl-faltable-general-lookup ans faltable)))
        (ans-table (if (atom ans)
            (hl-mht :size (cond ((natp ans) (max 60 ans))
                (alist-table (hash-table-size (the hash-table alist-table)))
                (t (max 60 (ash (len alist) -3)))))
            (hl-falslot-val ans-slot))))
      (setf (hl-falslot-key ans-slot) nil)
      (unless ans-table
        (hl-slow-alist-warning 'fast-alist-fork)
        (return-from hl-hspace-fast-alist-fork
          (hl-fast-alist-fork-aux-really-slow alist ans honsp hs)))
      (let ((new-alist (if alist-table
             (hl-fast-alist-fork-aux-fast alist ans ans-table honsp hs)
             (hl-fast-alist-fork-aux-slow alist ans ans-table honsp hs))))
        (when honsp
          (setq ans-slot
            (hl-faltable-general-lookup new-alist faltable))
          (when (hl-falslot-key ans-slot)
            (hl-alist-stolen-warning 'fast-alist-fork!)
            (return-from hl-hspace-fast-alist-fork new-alist)))
        (unless (atom new-alist)
          (setf (hl-falslot-val ans-slot) ans-table)
          (setf (hl-falslot-key ans-slot) new-alist))
        new-alist))))

(defun hl-fast-alist-clean-aux
  (alist ans table honsp hs)
  (declare (type hl-hspace hs)
    (type hash-table table))
  (cond ((atom alist) ans)
    ((or (atom (car alist)) (gethash (caar alist) table)) (hl-fast-alist-clean-aux (cdr alist) ans table honsp hs))
    (t (let* ((key (caar alist)) (entry (if honsp
              (hl-hspace-hons key (cdar alist) hs)
              (car alist)))
          (ans (if honsp
              (hl-hspace-hons entry ans hs)
              (cons entry ans))))
        (setf (gethash key table) entry)
        (hl-fast-alist-clean-aux (cdr alist) ans table honsp hs)))))

(defun hl-hspace-fast-alist-clean
  (alist honsp hs)
  (declare (type hl-hspace hs))
  (cond ((atom alist) alist)
    (t (let* ((ans (cdr (last alist))) (faltable (hl-hspace-faltable hs))
          (slot (hl-faltable-general-lookup alist faltable))
          (table (hl-falslot-val slot)))
        (cond ((null table) (return-from hl-hspace-fast-alist-clean
              (hl-hspace-fast-alist-fork alist ans honsp hs)))
          (t (setf (hl-falslot-key slot) nil)
            (clrhash table)
            (let ((new-alist (hl-fast-alist-clean-aux alist ans table honsp hs)))
              (setf (hl-falslot-key slot) new-alist))))))))

(defun hl-hspace-fast-alist-len
  (alist hs)
  (declare (type hl-hspace hs))
  (if (atom alist)
    0
    (let* ((faltable (hl-hspace-faltable hs)) (slot (hl-faltable-general-lookup alist faltable))
        (val (hl-falslot-val slot)))
      (if val
        (hash-table-count val)
        (progn (hl-slow-alist-warning 'fast-alist-len)
          (let* ((fast-alist (hl-hspace-fast-alist-fork alist nil nil hs)) (result (hl-hspace-fast-alist-len fast-alist hs)))
            (hl-hspace-fast-alist-free fast-alist hs)
            result))))))

(defun hl-check-alist-for-serialize-restore
  (alist hs)
  (declare (type hl-hspace hs))
  (cond ((atom alist) nil)
    ((atom (car alist)) (hl-check-alist-for-serialize-restore (cdr alist) hs))
    ((not (hl-hspace-normedp (caar alist) hs)) (error "Can't restore an alist from the serialized file since it has ~
                 a key that was not re-honsed.~%  ~
                  - Problematic key: ~S~%  ~
                  - Tail of alist: ~S~%"
        (caar alist)
        alist))
    (t (hl-check-alist-for-serialize-restore (cdr alist) hs))))

(defun hl-hspace-restore-fal-for-serialize
  (alist count hs)
  (declare (type hl-hspace hs))
  (let* ((faltable (hl-hspace-faltable hs)) (slot (hl-faltable-general-lookup alist faltable))
      (new-ht (hl-mht :size (max 60 count))))
    (hl-check-alist-for-serialize-restore alist hs)
    (hl-make-fast-alist-put-pairs alist new-ht)
    (when (hl-falslot-val slot)
      (hl-alist-stolen-warning 'hl-hspace-restore-fal-for-serialize))
    (setf (hl-falslot-val slot) new-ht)
    (setf (hl-falslot-key slot) alist)))

(defun hl-restore-fal-for-serialize
  (alist count)
  (declare (special *default-hs*))
  (hl-hspace-restore-fal-for-serialize alist
    count
    *default-hs*))

(defun hl-hspace-number-subtrees-aux
  (x seen)
  (declare (type hash-table seen))
  (cond ((atom x) nil)
    ((gethash x seen) nil)
    (t (progn (setf (gethash x seen) t)
        (hl-hspace-number-subtrees-aux (car x) seen)
        (hl-hspace-number-subtrees-aux (cdr x) seen)))))

(defun hl-hspace-number-subtrees
  (x hs)
  (declare (type hl-hspace hs))
  (let ((x (hl-hspace-norm x hs)) (seen (hl-mht :test 'eq :size 10000)))
    (hl-hspace-number-subtrees-aux x seen)
    (hash-table-count seen)))

(defun hl-faltable-clear-cache
  (faltable)
  (declare (type hl-faltable faltable))
  (hl-faltable-eject (hl-faltable-slot1 faltable) faltable)
  (hl-faltable-eject (hl-faltable-slot2 faltable) faltable)
  (setf (hl-faltable-eject1 faltable) nil))

(defun hl-system-gc nil (gc$))

(defun hl-hspace-classic-restore
  (x nil-ht cdr-ht cdr-ht-eql seen-ht)
  (declare (type hash-table nil-ht)
    (type hash-table cdr-ht)
    (type hash-table cdr-ht-eql)
    (type hash-table seen-ht))
  (cond ((atom x) x)
    ((gethash x seen-ht) x)
    (t (let* ((a (hl-hspace-classic-restore (car x)
             nil-ht
             cdr-ht
             cdr-ht-eql
             seen-ht)) (b (hl-hspace-classic-restore (cdr x)
              nil-ht
              cdr-ht
              cdr-ht-eql
              seen-ht)))
        (setf (gethash x seen-ht) t)
        (if (eq b nil)
          (setf (gethash a nil-ht) x)
          (let* ((main-table (if (or (consp b) (symbolp b) (typep b 'array))
                 cdr-ht
                 cdr-ht-eql)) (flex-alist (gethash b main-table))
              (was-alistp (listp flex-alist))
              (new-flex-alist (hl-flex-acons x flex-alist)))
            (when was-alistp
              (setf (gethash b main-table) new-flex-alist))
            x))))))

(defun hl-hspace-hons-clear
  (gc hs)
  (declare (type hl-hspace hs))
  (let* ((ctables (hl-hspace-ctables hs)) (nil-ht (hl-ctables-nil-ht ctables))
      (cdr-ht (hl-ctables-cdr-ht ctables))
      (cdr-ht-eql (hl-ctables-cdr-ht-eql ctables))
      (faltable (hl-hspace-faltable hs))
      (persist-ht (hl-hspace-persist-ht hs))
      (norm-cache (hl-hspace-norm-cache hs))
      (temp-nil-ht (hl-mht :test (function eql)))
      (temp-cdr-ht (hl-mht :test (function eq)))
      (temp-cdr-ht-eql (hl-mht :test (function eql)))
      (temp-ctables (make-hl-ctables :nil-ht temp-nil-ht
          :cdr-ht temp-cdr-ht
          :cdr-ht-eql temp-cdr-ht-eql))
      (temp-faltable (hl-faltable-init))
      (temp-persist-ht (hl-mht :test (function eq)))
      (seen-ht (hl-mht :test (function eq) :size 10000))
      (note-stream (get-output-stream-from-channel *standard-co*)))
    (hl-faltable-clear-cache faltable)
    (hl-cache-clear norm-cache)
    (setf (hl-hspace-faltable hs) temp-faltable)
    (setf (hl-hspace-persist-ht hs) temp-persist-ht)
    (setf (hl-hspace-ctables hs) temp-ctables)
    (hons-note note-stream "clearing normed objects.~%")
    (clrhash nil-ht)
    (clrhash cdr-ht)
    (clrhash cdr-ht-eql)
    (when gc (hl-system-gc))
    (hons-note note-stream
      "re-norming persistently normed objects.~%")
    (maphash (lambda (key val)
        (declare (ignore val))
        (hl-hspace-classic-restore key
          nil-ht
          cdr-ht
          cdr-ht-eql
          seen-ht))
      persist-ht)
    (hons-note note-stream "re-norming fast alist keys.~%")
    (hl-faltable-maphash (lambda (alist associated-hash-table)
        (declare (ignore alist))
        (maphash (lambda (key val)
            (declare (ignore val))
            (hl-hspace-classic-restore key
              nil-ht
              cdr-ht
              cdr-ht-eql
              seen-ht))
          associated-hash-table))
      faltable)
    (hons-note note-stream
      "finished re-norming ~a conses.~%"
      (hash-table-count seen-ht))
    (setf (hl-hspace-ctables hs) ctables)
    (setf (hl-hspace-faltable hs) faltable)
    (setf (hl-hspace-persist-ht hs) persist-ht))
  nil)

(defun hl-hspace-hons-wash
  (hs)
  (declare (type hl-hspace hs))
  (declare (ignore hs))
  (hons-note t
    "washing is not available for classic honsing.~%")
  nil)

(defun hl-maybe-resize-ht
  (size src)
  (declare (type hash-table src))
  (let* ((src-size (hash-table-size src)) (src-count (hash-table-count src))
      (min-reasonable-size (max 100 (* src-count 1.2)))
      (target-size (max min-reasonable-size size)))
    (if (and (< (* src-size 0.8) target-size)
        (< target-size (* src-size 1.2)))
      src
      (let ((new-ht (hl-mht :test (hash-table-test src) :size size)))
        (maphash (lambda (key val) (setf (gethash key new-ht) val))
          src)
        new-ht))))

(defun hl-hspace-resize
  (str-ht-size nil-ht-size
    cdr-ht-size
    cdr-ht-eql-size
    addr-ht-size
    other-ht-size
    sbits-size
    fal-ht-size
    persist-ht-size
    hs)
  (declare (type hl-hspace hs)
    (ignore addr-ht-size other-ht-size sbits-size))
  (when (natp str-ht-size)
    (setf (hl-hspace-str-ht hs)
      (hl-maybe-resize-ht str-ht-size (hl-hspace-str-ht hs))))
  (when (natp fal-ht-size)
    (let* ((faltable (hl-hspace-faltable hs)) (table (hl-faltable-table faltable)))
      (setf (hl-faltable-table faltable)
        (hl-maybe-resize-ht fal-ht-size table))))
  (when (natp persist-ht-size)
    (setf (hl-hspace-persist-ht hs)
      (hl-maybe-resize-ht persist-ht-size
        (hl-hspace-persist-ht hs))))
  (let ((ctables (hl-hspace-ctables hs)))
    (when (natp nil-ht-size)
      (setf (hl-ctables-nil-ht ctables)
        (hl-maybe-resize-ht nil-ht-size (hl-ctables-nil-ht ctables))))
    (when (natp cdr-ht-size)
      (setf (hl-ctables-cdr-ht ctables)
        (hl-maybe-resize-ht cdr-ht-size (hl-ctables-cdr-ht ctables))))
    (when (natp cdr-ht-eql-size)
      (setf (hl-ctables-cdr-ht-eql ctables)
        (hl-maybe-resize-ht cdr-ht-eql-size
          (hl-ctables-cdr-ht-eql ctables)))))
  nil)

(defun hl-get-final-cdr
  (alist)
  (if (atom alist)
    alist
    (hl-get-final-cdr (cdr alist))))

(defun hl-hspace-fast-alist-summary
  (hs)
  (declare (type hl-hspace hs))
  (let* ((faltable (hl-hspace-faltable hs)) (table (hl-faltable-table faltable))
      (total-count 0)
      (total-sizes 0)
      (total-num 0)
      (report-entries))
    (format t "~%Fast Alists Summary:~%~%")
    (force-output)
    (hl-faltable-maphash (lambda (alist associated-ht)
        (let* ((final-cdr (hl-get-final-cdr alist)) (size (hash-table-size associated-ht))
            (count (hash-table-count associated-ht)))
          (incf total-sizes size)
          (incf total-count count)
          (incf total-num)
          (push (list count size final-cdr) report-entries)))
      faltable)
    (format t " - Number of fast alists: ~15:D~%" total-num)
    (format t
      " - Size of FAL table:     ~15:D~%"
      (hash-table-size table))
    (format t " - Total of counts:       ~15:D~%" total-count)
    (format t " - Total of sizes:        ~15:D~%" total-sizes)
    (format t "~%")
    (force-output)
    (setq report-entries
      (sort report-entries
        (lambda (x y)
          (or (> (first x) (first y))
            (and (= (first x) (first y)) (> (second x) (second y)))))))
    (format t "Summary of individual fast alists:~%~%")
    (format t "      Count           Size         Name~%")
    (format t "  (used slots)     (capacity)~%")
    (format t
      "--------------------------------------------------~%")
    (loop for
      entry
      in
      report-entries
      do
      (format t
        "~10:D ~16:D        ~:D~%"
        (first entry)
        (second entry)
        (third entry)))
    (format t
      "--------------------------------------------------~%")
    (format t "~%")
    (force-output)))

(defun hl-hspace-hons-summary
  (hs)
  (declare (type hl-hspace hs))
  (format t "~%Normed Objects Summary~%~%")
  (let* ((ctables (hl-hspace-ctables hs)) (nil-ht (hl-ctables-nil-ht ctables))
      (cdr-ht (hl-ctables-cdr-ht ctables))
      (cdr-ht-eql (hl-ctables-cdr-ht-eql ctables)))
    (format t
      " - NIL-HT:       ~15:D count, ~15:D size (~5,2f% full)~%"
      (hash-table-count nil-ht)
      (hash-table-size nil-ht)
      (* (/ (hash-table-count nil-ht) (hash-table-size nil-ht))
        100.0))
    (format t
      " - CDR-HT:       ~15:D count, ~15:D size (~5,2f% full)~%"
      (hash-table-count cdr-ht)
      (hash-table-size cdr-ht)
      (* (/ (hash-table-count cdr-ht) (hash-table-size cdr-ht))
        100.0))
    (format t
      " - CDR-HT-EQL:   ~15:D count, ~15:D size (~5,2f% full)~%"
      (hash-table-count cdr-ht-eql)
      (hash-table-size cdr-ht-eql)
      (* (/ (hash-table-count cdr-ht-eql)
          (hash-table-size cdr-ht-eql))
        100.0)))
  (let ((str-ht (hl-hspace-str-ht hs)) (persist-ht (hl-hspace-persist-ht hs))
      (fal-ht (hl-faltable-table (hl-hspace-faltable hs))))
    (format t
      " - STR-HT:       ~15:D count, ~15:D size (~5,2f% full)~%"
      (hash-table-count str-ht)
      (hash-table-size str-ht)
      (* (/ (hash-table-count str-ht) (hash-table-size str-ht))
        100.0))
    (format t
      " - PERSIST-HT:   ~15:D count, ~15:D size (~5,2f% full)~%"
      (hash-table-count persist-ht)
      (hash-table-size persist-ht)
      (* (/ (hash-table-count persist-ht)
          (hash-table-size persist-ht))
        100.0))
    (format t
      " - FAL-HT:       ~15:D count, ~15:D size (~5,2f% full)~%~%"
      (hash-table-count fal-ht)
      (hash-table-size fal-ht)
      (* (/ (hash-table-count fal-ht) (hash-table-size fal-ht))
        100.0)))
  nil)

(defun hl-maybe-initialize-default-hs
  nil
  (unless *default-hs* (setq *default-hs* (hl-hspace-init))))

(defun hl-maybe-initialize-default-hs-wrapper
  nil
  (hl-maybe-initialize-default-hs))

(defun hons
  (x y)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-hons x y *default-hs*))

(defun hons-copy
  (x)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-norm x *default-hs*))

(defun hons-copy-persistent
  (x)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-persistent-norm x *default-hs*))

(defun hons-equal
  (x y)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-hons-equal x y *default-hs*))

(defun hons-equal-lite
  (x y)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-hons-equal-lite x y *default-hs*))

(defun hons-summary
  nil
  (hl-maybe-initialize-default-hs)
  (hl-hspace-hons-summary *default-hs*))

(defun hons-clear!
  (gc)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-hons-clear gc *default-hs*))

(defun hons-clear (gc) (hons-clear! gc))

(defun hons-wash!
  nil
  (hl-maybe-initialize-default-hs)
  (hl-hspace-hons-wash *default-hs*)
  nil)

(defun hons-wash nil (hons-wash!))

(defun hons-resize-fn
  (str-ht nil-ht
    cdr-ht
    cdr-ht-eql
    addr-ht
    other-ht
    sbits
    fal-ht
    persist-ht)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-resize str-ht
    nil-ht
    cdr-ht
    cdr-ht-eql
    addr-ht
    other-ht
    sbits
    fal-ht
    persist-ht
    *default-hs*))

(defun hons-acons
  (key val fal)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-hons-acons key val fal *default-hs*))

(defun hons-acons!
  (key val fal)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-hons-acons! key val fal *default-hs*))

(defun fast-alist-fork
  (alist ans)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-fast-alist-fork alist ans nil *default-hs*))

(defun fast-alist-fork!
  (alist ans)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-fast-alist-fork alist ans t *default-hs*))

(defun fast-alist-clean
  (alist)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-fast-alist-clean alist nil *default-hs*))

(defun fast-alist-clean!
  (alist)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-fast-alist-clean alist t *default-hs*))

(defun hons-get
  (key fal)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-hons-get key fal *default-hs*))

(defun fast-alist-free
  (fal)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-fast-alist-free fal *default-hs*))

(defun fast-alist-len
  (fal)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-fast-alist-len fal *default-hs*))

(defun number-subtrees
  (x)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-number-subtrees x *default-hs*))

(defun fast-alist-summary
  nil
  (hl-maybe-initialize-default-hs)
  (hl-hspace-fast-alist-summary *default-hs*))

(defun make-fast-alist
  (alist)
  (hl-maybe-initialize-default-hs)
  (hl-hspace-make-fast-alist alist *default-hs*))