common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Fix Perfect hash generator failure, lp#2055794

Browse source 
The C code should not fail on these inputs, and there's not much I can do
without thoroughly grokking Bob Jenkins' code, but two things can work better:
(1) the API I made was broken in that it didn't detect the failure
(2) if it does fail on a set of exactly 2^N keys, where minimal-perfect is
    the same as "non-minimal" perfect, try either. It might magically work.
This commit is contained in:
Douglas Katzman 2024-03-03 18:12:55 -05:00
parent 2601f0d126
commit 5a23a28ce7
3 changed files with 47 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

39
src/compiler/sxhash.lisp
View file

@ -220,21 +220,30 @@
(setf cache (make-hash-table :test 'equalp :synchronized t)
*phash-lambda-cache* cache))
(or (gethash cache-key cache)
(let* ((string
(sb-unix::newcharstar-string
(sb-sys:with-pinned-objects (array)
(alien-funcall
(extern-alien
"lisp_perfhash_with_options"
(function (* char) int system-area-pointer int))
(logior (if minimal 1 0) (if fast 2 0))
(sb-sys:vector-sap array) (length array)))))
(expr (with-standard-io-syntax
(let ((*package* #.(find-package "SB-C")))
(read-from-string string)))))
(when cacheable (setf (gethash cache-key cache) expr))
(setf returned-string string)
expr)))))
(flet ((findit (minimal)
(sb-unix::newcharstar-string
(sb-sys:with-pinned-objects (array)
(alien-funcall
(extern-alien
"lisp_perfhash_with_options"
(function (* char) int system-area-pointer int))
(logior (if minimal 1 0) (if fast 2 0))
(sb-sys:vector-sap array) (length array))))))
(let ((string (findit minimal)))
(when (and (not string)
(= (length array) (power-of-two-ceiling (length array)))
minimal)
;; Possibly try again as non-minimal because it's equivalent on 2^N keys.
;; This should NOT be needed but it works around a deficiency
;; in C which I am not smart enough to fix.
(when (null (setq string (findit nil)))
(return-from make-perfect-hash-lambda nil)))
(let ((expr (with-standard-io-syntax
(let ((*package* #.(find-package "SB-C")))
(read-from-string string)))))
(when cacheable (setf (gethash cache-key cache) expr))
(setf returned-string string)
expr)))))))
(let ((tables))
;; Hoist the constants into symbol-macrolets rather than LETs
;; because my work-in-progress 32-bit-modular-arithmetic optimizer

4
src/runtime/perfecthash.c
View file

@ -676,7 +676,7 @@ int findhash(
{
duplicates(*tabb, *blen, keys, form); /* check for duplicates */
// printf("fatal error: Cannot perfect hash: cannot find distinct (A,B)\n");
return 0; // failure
return -1; // failure
}
bad_initkey = 0;
bad_perfect = 0;
@ -704,7 +704,7 @@ int findhash(
else
{
// printf("fatal error: Cannot perfect hash: cannot build tab[]\n");
return 0; // failure
return -1; // failure
}
bad_perfect = 0;
}

21
tests/perfecthash.impure.lisp
View file

@ -668,3 +668,24 @@ After:
;; all the simple expressions needed when cross-compiling
;; can be emitted using at most 4 temps
(assert (<= (test-all file) 4))))
(defvar *bug-2055794-test-form*
'(case x
((#\g 5) 1)
((#\} #\j #\y #\$) 2)
((#\- #\|) 3)
((#\X) 4)
((0 7 4 #\% 3) 5)
((#\{) 6)
((#\l) 7)
(t 'dropthru)))
(defun bug-2055794-tester (x) #.*bug-2055794-test-form*)
(with-test (:name :lp-2055794)
(dolist (clause (butlast (cddr *bug-2055794-test-form*)))
(dolist (key (car clause))
(let ((answer (bug-2055794-tester key)))
(assert (eq answer (second clause))))))
(dolist (key '(foo bar baz))
(assert (eq (bug-2055794-tester key) 'dropthru))))