From 2ac506e4c6f39f750c6f80c28b813f9908dfbb7f Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 5 Jan 2022 20:38:04 +0000 Subject: [PATCH 1/2] Better error message in legacy optimized implementation for sbcl When optimizing, the array bounds check is performed with a single comparison, jumping to an internal error if the check is violated. Arrange that the error refers to an array index that is in fact out of bounds. --- sbcl-opt/x86-64-vm.lisp | 6 +++--- sbcl-opt/x86-vm.lisp | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/sbcl-opt/x86-64-vm.lisp b/sbcl-opt/x86-64-vm.lisp index afb095b..fb6d71a 100644 --- a/sbcl-opt/x86-64-vm.lisp +++ b/sbcl-opt/x86-64-vm.lisp @@ -20,7 +20,7 @@ (:vop-var vop) (:generator 5 (let ((error (generate-error-code vop 'invalid-array-index-error - array bound index))) + array bound temp))) ;; We want to check the conditions: ;; ;; 0 <= INDEX @@ -36,9 +36,9 @@ ;; If INDEX + OFFSET <_u BOUND, though, INDEX must be less than ;; BOUND. We *do* need to check for 0 <= INDEX, but that has ;; already been assured by higher-level machinery. - (inst lea temp (ea (fixnumize offset) nil index)) + (inst lea temp (ea (fixnumize (1- offset)) nil index)) (inst cmp temp bound) - (inst jmp :a error) + (inst jmp :ae error) (move result index)))) #.(flet ((frob (bitsize setterp signedp big-endian-p) diff --git a/sbcl-opt/x86-vm.lisp b/sbcl-opt/x86-vm.lisp index 3d18fe8..0f8c5a3 100644 --- a/sbcl-opt/x86-vm.lisp +++ b/sbcl-opt/x86-vm.lisp @@ -20,7 +20,7 @@ (:vop-var vop) (:generator 5 (let ((error (generate-error-code vop 'invalid-array-index-error - array bound index))) + array bound temp))) ;; We want to check the conditions: ;; ;; 0 <= INDEX @@ -36,9 +36,9 @@ ;; If INDEX + OFFSET <_u BOUND, though, INDEX must be less than ;; BOUND. We *do* need to check for 0 <= INDEX, but that has ;; already been assured by higher-level machinery. - (inst lea temp (make-ea :dword :index index :disp (fixnumize offset))) + (inst lea temp (make-ea :dword :index index :disp (fixnumize (1- offset)))) (inst cmp temp bound) - (inst jmp :a error) + (inst jmp :ae error) (move result index)))) #.(flet ((frob (setterp signedp big-endian-p) From b2959ed505052662715676b5600416533cbc6ff6 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 5 Jan 2022 20:22:19 +0000 Subject: [PATCH 2/2] Use sb-nibbles contrib module, if available If it is available, the corresponding package is present in the image when compiling, so use that to conditionally compile legacy support or support based on sb-nibbles as applicable. The support based on the new module simply transforms each nibbles vector accessor into the corresponding sb-nibbles one. Tested with SBCL with sb-nibbles, SBCL without sb-nibbles, and Clozure Common Lisp (all x86-64). --- nibbles.asd | 1 + sbcl-opt/fndb.lisp | 40 ++++++++++++++++++++++++++++++++++++ sbcl-opt/nib-tran.lisp | 45 +++++++++++++++++++++++++++++++++++++++++ sbcl-opt/x86-64-vm.lisp | 4 ++-- sbcl-opt/x86-vm.lisp | 4 ++-- 5 files changed, 90 insertions(+), 4 deletions(-) diff --git a/nibbles.asd b/nibbles.asd index 0198548..abe0ea8 100644 --- a/nibbles.asd +++ b/nibbles.asd @@ -25,6 +25,7 @@ :maintainer "Sharp Lispers " :description "A library for accessing octet-addressed blocks of data in big- and little-endian orders" :license "BSD-style (http://opensource.org/licenses/BSD-3-Clause)" + :weakly-depends-on ("sb-nibbles") :default-component-class nibbles-source-file :components ((:static-file "README.md") (:static-file "LICENSE") diff --git a/sbcl-opt/fndb.lisp b/sbcl-opt/fndb.lisp index 45e20a9..4a3c79c 100644 --- a/sbcl-opt/fndb.lisp +++ b/sbcl-opt/fndb.lisp @@ -4,6 +4,44 @@ #+sbcl (progn +#+#.(cl:if (cl:find-package "SB-NIBBLES") '(:and) '(:or)) (progn + +(macrolet ((def (name size signedp setterp be-p) + (let* ((result-type `(,(if signedp 'signed-byte 'unsigned-byte) ,size)) + (arg-types `(array index ,@(when setterp (list result-type))))) + `(sb-c:defknown ,name ,arg-types ,result-type (sb-c:any) + :overwrite-fndb-silently t)))) + (def ub16ref/be 16 nil nil t) + (def ub16ref/le 16 nil nil nil) + (def ub16set/be 16 nil t t) + (def ub16set/le 16 nil t nil) + (def sb16ref/be 16 t nil t) + (def sb16ref/le 16 t nil nil) + (def sb16set/be 16 t t t) + (def sb16set/le 16 t t nil) + + (def ub32ref/be 32 nil nil t) + (def ub32ref/le 32 nil nil nil) + (def ub32set/be 32 nil t t) + (def ub32set/le 32 nil t nil) + (def sb32ref/be 32 t nil t) + (def sb32ref/le 32 t nil nil) + (def sb32set/be 32 t t t) + (def sb32set/le 32 t t nil) + + (def ub64ref/be 64 nil nil t) + (def ub64ref/le 64 nil nil nil) + (def ub64set/be 64 nil t t) + (def ub64set/le 64 nil t nil) + (def sb64ref/be 64 t nil t) + (def sb64ref/le 64 t nil nil) + (def sb64set/be 64 t t t) + (def sb64set/le 64 t t nil)) + +);#+(find-package "SB-NIBBLES") + +#-#.(cl:if (cl:find-package "SB-NIBBLES") '(:and) '(:or)) (progn + ;;; Efficient array bounds checking (sb-c:defknown %check-bound ((simple-array (unsigned-byte 8) (*)) index (and fixnum sb-vm:word) @@ -42,4 +80,6 @@ ,arg-type (sb-c:any) :overwrite-fndb-silently t) into defknowns finally (return `(progn ,@defknowns))) +);#-(find-package "SB-NIBBLES") + );#+sbcl diff --git a/sbcl-opt/nib-tran.lisp b/sbcl-opt/nib-tran.lisp index 62b1094..4eb8c2d 100644 --- a/sbcl-opt/nib-tran.lisp +++ b/sbcl-opt/nib-tran.lisp @@ -4,6 +4,49 @@ #+sbcl (progn +#+#.(cl:if (cl:find-package "SB-NIBBLES") '(:and) '(:or)) (progn + +(macrolet ((def (name size signedp setterp be-p) + (let* ((arglist `(vector offset ,@(when setterp '(value)))) + (sb-name (find-symbol (symbol-name name) "SB-NIBBLES")) + (result-type `(,(if signedp 'signed-byte 'unsigned-byte) ,size)) + (arg-types `(array index ,@(when setterp (list result-type))))) + (when sb-name + `(sb-c:deftransform ,name (,arglist ,arg-types ,result-type) + `(progn + (,',sb-name vector (sb-nibbles::%check-bound vector (length vector) offset ,',(truncate size 8)) ,@',(when setterp '(value))) + ,@',(when setterp '(value)))))))) + (def ub16ref/be 16 nil nil t) + (def ub16ref/le 16 nil nil nil) + (def ub16set/be 16 nil t t) + (def ub16set/le 16 nil t nil) + (def sb16ref/be 16 t nil t) + (def sb16ref/le 16 t nil nil) + (def sb16set/be 16 t t t) + (def sb16set/le 16 t t nil) + + (def ub32ref/be 32 nil nil t) + (def ub32ref/le 32 nil nil nil) + (def ub32set/be 32 nil t t) + (def ub32set/le 32 nil t nil) + (def sb32ref/be 32 t nil t) + (def sb32ref/le 32 t nil nil) + (def sb32set/be 32 t t t) + (def sb32set/le 32 t t nil) + + (def ub64ref/be 64 nil nil t) + (def ub64ref/le 64 nil nil nil) + (def ub64set/be 64 nil t t) + (def ub64set/le 64 nil t nil) + (def sb64ref/be 64 t nil t) + (def sb64ref/le 64 t nil nil) + (def sb64set/be 64 t t t) + (def sb64set/le 64 t t nil)) + +);#+(find-package "SB-NIBBLES") + +#-#.(cl:if (cl:find-package "SB-NIBBLES") '(:and) '(:or)) (progn + (sb-c:deftransform %check-bound ((vector bound offset n-bytes) ((simple-array (unsigned-byte 8) (*)) index (and fixnum sb-vm:word) @@ -93,4 +136,6 @@ collect generic-little-transform into transforms finally (return `(progn ,@transforms)))) +);#-(find-package "SB-NIBBLES") + );#+sbcl diff --git a/sbcl-opt/x86-64-vm.lisp b/sbcl-opt/x86-64-vm.lisp index fb6d71a..f07e8c0 100644 --- a/sbcl-opt/x86-64-vm.lisp +++ b/sbcl-opt/x86-64-vm.lisp @@ -3,7 +3,7 @@ #+sbcl (cl:in-package :sb-vm) -#+(and sbcl x86-64) (progn +#+(and sbcl x86-64 #.(cl:if (cl:find-package "SB-NIBBLES") '(:or) '(:and))) (progn (define-vop (%check-bound) (:translate nibbles::%check-bound) @@ -134,4 +134,4 @@ collect (frob bitsize setterp signedp big-endian-p) into forms finally (return `(progn ,@forms)))) -);#+(and sbcl x86-64) +);#+(and sbcl x86-64 (not (find-package "SB-NIBBLES"))) diff --git a/sbcl-opt/x86-vm.lisp b/sbcl-opt/x86-vm.lisp index 0f8c5a3..ece04ce 100644 --- a/sbcl-opt/x86-vm.lisp +++ b/sbcl-opt/x86-vm.lisp @@ -3,7 +3,7 @@ #+sbcl (cl:in-package :sb-vm) -#+(and sbcl x86) (progn +#+(and sbcl x86 #.(cl:if (cl:find-package "SB-NIBBLES") '(:or) '(:and))) (progn (define-vop (%check-bound) (:translate nibbles::%check-bound) @@ -162,4 +162,4 @@ collect (frob setterp signedp big-endian-p) into forms finally (return `(progn ,@forms)))) -);#+(and sbcl x86) +);#+(and sbcl x86 (not (find-package "SB-NIBBLES")))