Derive the type of make-array-header*

Fixes lp#1838442
sbcl · Jul 30, 2019 · c84daa0 · c84daa0
1 parent fc789b6
commit c84daa0
Show file tree

Hide file tree

Showing 3 changed files with 28 additions and 0 deletions.
diff --git a/NEWS b/NEWS
@@ -1,5 +1,9 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 
+changes relative to sbcl-1.5.6:
+  * optimization: improved make-array type derivation for multi-dimensional
+    arrays. (lp#1838442)
+
 changes in sbcl-1.5.5 relative to sbcl-1.5.4:
   * platform support:
     - SunOS: bug reports and patches from Richard Lowe in sb-posix tests

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
@@ -345,6 +345,18 @@
                           fill-pointer displaced-to
                           node))
 
+(defoptimizer (make-array-header* derive-type) ((&rest inits))
+  (let* ((data-position #.(sb-vm::slot-offset
+                           (find 'sb-vm::data (sb-vm:primitive-object-slots
+                                               (find 'array sb-vm:*primitive-objects*
+                                                     :key 'sb-vm:primitive-object-name))
+                                 :key 'sb-vm::slot-name)))
+         (data (nth data-position inits))
+         (type (lvar-type data)))
+    (when (array-type-p type)
+      (make-array-type '* :element-type (array-type-element-type type)
+                          :specialized-element-type (array-type-specialized-element-type type)))))
+
 (defoptimizer (%make-array derive-type)
     ((dims widetag n-bits &key adjustable fill-pointer displaced-to
            &allow-other-keys)

diff --git a/tests/array.pure.lisp b/tests/array.pure.lisp
@@ -564,3 +564,15 @@
          (declare (fixnum y))
          (svref x (+ y 2)))
     ((#(1 2 3) 0) 3)))
+
+(with-test (:name :make-array-header*-type-derivation)
+  (let ((fun (checked-compile
+              '(lambda (a)
+                (declare ((simple-array (unsigned-byte 8) (*)) a))
+                (make-array '(10 20) :element-type (array-element-type a))))))
+    (assert (typep (funcall fun #A((1) (UNSIGNED-BYTE 8) 0))
+                   '(simple-array (unsigned-byte 8) (10 20))))
+    (assert
+     (equal (sb-kernel:%simple-fun-type fun)
+            '(function ((simple-array (unsigned-byte 8) (*)))
+              (values (simple-array (unsigned-byte 8) (10 20)) &optional))))))