From e9a598e534d816ac62be63f93f3d194ca1c49930 Mon Sep 17 00:00:00 2001
From: Raymond Toy <toy.raymond@gmail.com>
Date: Mon, 19 Feb 2018 08:41:07 -0800
Subject: [PATCH] Complex array accessors are not foldable

Fixes #61 and #62.

The `ARRAY-HAS-FILL-POINTER-P` and `ARRAY-DISPLACEMENT` functions are
declared inline and the compiler tries to constant-fold these inlined
functions operating on simple arrays.

Thus don't allow the compiler to constant-fold calls to
`%ARRAY-FILL-POINTER-P`.  This is normally protected by a call to
`ARRAY-HEADER-P`, but when it's inlined, the compiler tries to
constant-fold `%ARRAY-FILL-POINTER-P` on an array without such a slot.

Likewise `ARRAY-DISPLACEMENT` calls `%ARRAY-DISPLACED-P`,
`%ARRAY-DATA-VECTOR`, and `%ARRAY-DISPLACEMENT`, and the calls are
protected by `ARRAY-HEADER-P`. So don't constant-fold these either.

Maybe we could also make CONSTANT-FOLD-CALL be smarter about this?

* src/compiler/generic/objdef.lisp
  * Remove flushable from these ref-trans methods.
* src/general-info/release-21d.md
  * Update
* tests/issues.lisp
  * Add tests from the bug reports.
---
 src/compiler/generic/objdef.lisp | 13 ++++++++-----
 src/general-info/release-21d.md  |  2 ++
 tests/issues.lisp                | 14 ++++++++++++++
 3 files changed, 24 insertions(+), 5 deletions(-)

diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp
index d64178a53..55d3a9300 100644
--- a/src/compiler/generic/objdef.lisp
+++ b/src/compiler/generic/objdef.lisp
@@ -252,29 +252,32 @@
 		:ref-known (flushable foldable)
 		:set-trans (setf %array-fill-pointer)
 		:set-known (unsafe))
+  ;; Don't let these ref-trans to be constant-folded because these
+  ;; might get called on arrays that don't have these slots. (Because
+  ;; the lisp functions might be inlined.)
   (fill-pointer-p :type (member t nil)
 		  :ref-trans %array-fill-pointer-p
-		  :ref-known (flushable foldable)
+		  :ref-known (flushable)
 		  :set-trans (setf %array-fill-pointer-p)
 		  :set-known (unsafe))
   (elements :type index
 	    :ref-trans %array-available-elements
-	    :ref-known (flushable foldable)
+	    :ref-known (flushable)
 	    :set-trans (setf %array-available-elements)
 	    :set-known (unsafe))
   (data :type array
 	:ref-trans %array-data-vector
-	:ref-known (flushable foldable)
+	:ref-known (flushable)
 	:set-trans (setf %array-data-vector)
 	:set-known (unsafe))
   (displacement :type (or index null)
 		:ref-trans %array-displacement
-		:ref-known (flushable foldable)
+		:ref-known (flushable)
 		:set-trans (setf %array-displacement)
 		:set-known (unsafe))
   (displaced-p :type (member t nil)
 	       :ref-trans %array-displaced-p
-	       :ref-known (flushable foldable)
+	       :ref-known (flushable)
 	       :set-trans (setf %array-displaced-p)
 	       :set-known (unsafe))
   (dimensions :rest-p t))
diff --git a/src/general-info/release-21d.md b/src/general-info/release-21d.md
index 7940e53fb..19fdf0dea 100644
--- a/src/general-info/release-21d.md
+++ b/src/general-info/release-21d.md
@@ -35,6 +35,8 @@ public domain.
     * ~~#59~~ Incorrect type-derivation for `decode-float`
     * ~~#60~~ The function `C::%UNARY-FROUND` is undefined
     * ~~#58~~ Bogus type error in comparison of complex number with `THE` form
+    * ~~#61~~ Segfault when compiling call to `ARRAY-HAS-FILL-POINTER-P` on bit vector constant
+    * ~~#62~~ Segfault when compiling `ARRAY-DISPLACEMENT` on a string constant
   * Other changes:
   * Improvements to the PCL implementation of CLOS:
   * Changes to building procedure:
diff --git a/tests/issues.lisp b/tests/issues.lisp
index eda48a349..1df4ff2ac 100644
--- a/tests/issues.lisp
+++ b/tests/issues.lisp
@@ -521,3 +521,17 @@
   (let ((c9 (compile nil #'(lambda (x)
 			     (= (the (eql 1.0d0) x) #c(1/2 1/2))))))
     (assert-false (funcall c9 1.d0))))
+
+(define-test issue.61
+  (:tag :issues)
+  ;; Verifies that the compiler doesn't segfault and that we return
+  ;; the correct value.
+  (assert-false
+   (funcall (compile nil '(lambda () (array-has-fill-pointer-p #*10))))))
+
+(define-test issue.62
+  (:tag :issues)
+  ;; Verifies that the compiler doesn't segfault and that we return
+  ;; the correct value.
+  (assert-false
+   (funcall (compile nil '(lambda () (array-displacement "aaaaaaaa"))))))
-- 
GitLab