Skip to content
Snippets Groups Projects
Commit 7fbf5590 authored by toy's avatar toy
Browse files

Port over SBCL's fix for the Entomotomy bug

array-element-type-treated-as-declaration

wherein the compiler believes type declarations on array elements
without checking them, e.g.

	(DECLAIM (OPTIMIZE (SAFETY 3) (SPEED 1) (SPACE 1)))
	(DEFSTRUCT FOO A B)
	(DEFUN BAR (X)
	  (DECLARE (TYPE (SIMPLE-ARRAY CONS 1) X))
	  (WHEN (CONSP (AREF X 0))
	    (PRINT (AREF X 0))))
	(BAR (VECTOR (MAKE-FOO :A 11 :B 12)))

prints a structure out.

This patch makes the compiler use the specialized (upgraded) element
type instead of the declared element type for aref.
parent 7ca74850
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.28 2000/07/06 18:37:00 dtc Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.29 2002/10/15 21:23:13 toy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -59,7 +59,7 @@ ...@@ -59,7 +59,7 @@
(let ((type (continuation-type array))) (let ((type (continuation-type array)))
(when (array-type-p type) (when (array-type-p type)
(assert-continuation-optional-type new-value (assert-continuation-optional-type new-value
(array-type-element-type type)))) (array-type-specialized-element-type type))))
(continuation-type new-value)) (continuation-type new-value))
;;; Unsupplied-Or-NIL -- Internal ;;; Unsupplied-Or-NIL -- Internal
...@@ -87,7 +87,7 @@ ...@@ -87,7 +87,7 @@
;; If the node continuation has a single use then assert its type. ;; If the node continuation has a single use then assert its type.
(let ((cont (node-cont node))) (let ((cont (node-cont node)))
(when (= (length (find-uses cont)) 1) (when (= (length (find-uses cont)) 1)
(assert-continuation-type cont (extract-element-type array)))) (assert-continuation-type cont (extract-upgraded-element-type array))))
(extract-upgraded-element-type array)) (extract-upgraded-element-type array))
;;; %ASET -- derive-type optimizer. ;;; %ASET -- derive-type optimizer.
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.45 2002/08/08 15:37:38 toy Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-tran.lisp,v 1.46 2002/10/15 21:23:14 toy Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -59,7 +59,7 @@ ...@@ -59,7 +59,7 @@
(let ((dims (array-type-dimensions array-type))) (let ((dims (array-type-dimensions array-type)))
(when (and (consp dims) (= (length dims) 1)) (when (and (consp dims) (= (length dims) 1))
(give-up)) (give-up))
(let* ((el-type (array-type-element-type array-type)) (let* ((el-type (array-type-specialized-element-type array-type))
(total-size (if (or (atom dims) (member '* dims)) (total-size (if (or (atom dims) (member '* dims))
'* '*
(reduce #'* dims))) (reduce #'* dims)))
...@@ -84,7 +84,7 @@ ...@@ -84,7 +84,7 @@
(give-up)) (give-up))
(delay-transform node :optimize) (delay-transform node :optimize)
(let* ((dims (array-type-dimensions array-type)) (let* ((dims (array-type-dimensions array-type))
(el-type (array-type-element-type array-type)) (el-type (array-type-specialized-element-type array-type))
(total-size (if (or (atom dims) (member '* dims)) (total-size (if (or (atom dims) (member '* dims))
'* '*
(reduce #'* dims))) (reduce #'* dims)))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment