Remove array bounds checking from perfect hash lambdas

src/code/target-defstruct.lisp

@@ -567,7 +567,7 @@
 ;;; for collision resolution is so infrequent that rather than resolving it by
 ;;; chosing different input bits, the lambda expression wrapped around the
 ;;; perfect hash should resolve collisions via another alist.
-(defun make-hash-based-slot-mapper (slots)
+(defun make-hash-based-slot-mapper (slots lambda-name)
   (flet ((hash (s) (ldb (byte 32 0) (symbol-hash s))))
     (binding* ((symbols (map 'vector #'car slots))
                (hashes (map '(simple-array (unsigned-byte 32) (*))
@@ -615,7 +615,8 @@
         ;; since the above bucketing already asserted that hashing worked.
         (values (compile
                  nil
-                 `(lambda (symbol) ; this resembles the ASSOC transform
+                 ;; this resembles the ASSOC transform
+                 `(named-lambda ,lambda-name (symbol)
                     ,optimize-decl
                     (let* ((sb-c::val (ldb (byte 32 0) (symbol-hash symbol)))
                            (h (progn ,@body)))
@@ -625,6 +626,8 @@
 (defun make-struct-slot-map (dd)
   (make-hash-based-slot-mapper
    (mapcar (lambda (dsd) (cons (dsd-name dsd) (dsd-bits dsd)))
-           (dd-slots dd))))
+           (dd-slots dd))
+   ;; Prevent random junk like (lambda (symbol) in "very-long-name-why-why-why")
+   `(slot-mapper ,(dd-name dd))))
 
 (/show0 "target-defstruct.lisp end of file")

src/compiler/sxhash.lisp

@@ -197,7 +197,8 @@
                                        (minimal t) (fast nil) (cacheable t))
   (declare (type (simple-array (unsigned-byte 32) (*)) array))
   (declare (ignorable objects minimal fast cacheable))
-  (when (< (length array) 3) ; one or two keys - why are you doing this?
+  (when (or (< (length array) 3) ; one or two keys - why are you doing this?
+            (>= (length array) (ash 1 31))) ; insanity if this many
     (return-from make-perfect-hash-lambda))
   (unless (ub32-collection-uniquep array)
     (return-from make-perfect-hash-lambda))
@@ -268,8 +269,13 @@
                      expr))))
       (let* ((result-type `(mod ,(power-of-two-ceiling (length array))))
              (calc `(the ,result-type (uint32-modularly ,@expr))))
+        ;; Noting that the output of Bob's perfect hash generator was originally
+        ;; intended to be compiled into C, and we've adapted it to Lisp,
+        ;; it is not necessary to insert array-bounds-checks
+        ;; even if users declaim that optimization quality to be 3.
         (values `(lambda (val)
                    (declare (optimize (safety 0) (speed 3) (debug 0)
+                                      (sb-c:insert-array-bounds-checks 0)
                                       (sb-c:store-source-form 0)))
                    (declare (type (unsigned-byte 32) val))
                    ,(if tables `(symbol-macrolet ,tables ,calc) calc))

src/compiler/x86-64/arith.lisp

@@ -3979,9 +3979,14 @@
         (inst bts res posn)
         (inst btr res posn))))
 
-(defknown calc-phash ((unsigned-byte 32) (integer 1 5) simple-vector)
+(defknown calc-phash ((unsigned-byte 32) (integer 1 4) simple-vector)
   (unsigned-byte 32) (flushable always-translatable))
 
+;;; TODO: sometimes there's (LDB (BYTE 32 0) KEY) in front of the calculation
+;;; which we don't need, or rather, need but can be done in the vop basically
+;;; for free compared to referencing #x1FFFFFFFE as a code header constant.
+;;; Even if the initial untagging right-shift is required to use a :QWORD
+;;; operand size, it could be followed by a :DWORD mov into the same register.
 (define-vop ()
   (:translate calc-phash)
   (:args (arg :scs (any-reg) :target temp0))
@@ -4055,13 +4060,9 @@
                (inst* op dest src))
               (t
                (inst* op :dword dest src)))))
-    ;; Move result and re-tag. If the last step is an AND leaving 31 or fewer
-    ;; significant bits, then the operand size is :DWORD
+    ;; Move result and re-tag. Restrict the output to 31 significant bits,
+    ;; totally reasonable considering that you'd probably have to wait for
+    ;; days to produce a perfect hash function of 2 billion keys.
     (let* ((step (svref steps (1- (length steps))))
-           (tn (second step))
-           (size (if (and (eq (car step) 'and)
-                          (fixnump (third step))
-                          (<= (integer-length (third step)) 31))
-                     :dword
-                     :qword)))
-      (inst lea size res (ea tn tn)))))
+           (tn (second step)))
+      (inst lea :dword res (ea tn tn)))))

tests/symbol.pure.lisp

@@ -151,7 +151,8 @@
         (push (cons symbol (incf arb-value)) alist)))
     ;; the mapper shouldn't be a simple-vector
     (let ((function
-           (the function (sb-kernel::make-hash-based-slot-mapper alist))))
+           (the function (sb-kernel::make-hash-based-slot-mapper
+                          alist "foo"))))
       ;; now try it
       (dolist (pair alist)
         (let* ((key (car pair))