From 796b1dc30c9c8ba08f0d4d73b1f65f02d9e25fff Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Tue, 14 Dec 2004 21:51:35 +0000
Subject: [PATCH] o Remove the :derive-type option from the defknowns for
 concatenate   and make-sequence o Add derive-type optimizers for concatenate
 and make-sequence that   only derives the type when the output sequence
 specifier is a   subtype of sequence.  (Only done for constant specifiers.)

These changes fix the bug where the compiler deletes all code,
including the return for (defun foo () (concatenate 'fixnum '(1 2 3))).

This is caused by confusion in the compiler where derive-node-type
conflicts with the declared return type and causes all trailing blocks
to be deleted.
---
 compiler/fndb.lisp    | 21 +++++++++------------
 compiler/seqtran.lisp | 24 ++++++++++++++++++++++--
 2 files changed, 31 insertions(+), 14 deletions(-)

diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp
index 032a955eb..372c20606 100644
--- a/compiler/fndb.lisp
+++ b/compiler/fndb.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.127 2004/12/09 21:48:21 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.128 2004/12/14 21:51:35 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -404,20 +404,17 @@
 (defknown nreverse (sequence) sequence ()
   :derive-type #'result-type-first-arg/reverse)
 
-;; I (rtoy) changed the result types for make-sequence and concatenate
-;; from consed-sequence to t because the compiler will sometimes
-;; delete all following code when given a bad type-specifier.  For
-;; example (defun foo () (concatenate 'fixnum '(a b c))) deletes
-;; everything, including the return from foo, so we get an illegal
-;; instruction when the PC runs into the arg-count error.  Similar
-;; thing happens with make-sequence.
-(defknown make-sequence (type-specifier index &key (:initial-element t)) t
+(defknown make-sequence (type-specifier index &key (:initial-element t)) consed-sequence
   (movable flushable unsafe)
-  :derive-type (result-type-specifier-nth-arg 1))
+  ;; Nope:  If the type-specifier isn't a consed-sequence, we get confused.
+  ;;:derive-type (result-type-specifier-nth-arg 1)
+  )
 
-(defknown concatenate (type-specifier &rest sequence) t
+(defknown concatenate (type-specifier &rest sequence) consed-sequence
   (flushable)
-  :derive-type (result-type-specifier-nth-arg 1))
+  ;; Nope:  If the type-specifier isn't a consed-sequence, we get confused.
+  ;;:derive-type (result-type-specifier-nth-arg 1)
+  )
 
 (defknown map (type-specifier callable sequence &rest sequence) consed-sequence
   (flushable call dynamic-extent-closure-safe)
diff --git a/compiler/seqtran.lisp b/compiler/seqtran.lisp
index 33eb91196..d207815c9 100644
--- a/compiler/seqtran.lisp
+++ b/compiler/seqtran.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/seqtran.lisp,v 1.29 2004/12/09 21:49:03 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/seqtran.lisp,v 1.30 2004/12/14 21:51:35 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -580,4 +580,24 @@
       (if spec
 	  (specifier-type spec)
 	  (specifier-type 'null)))))
-    
+
+(defun output-spec-sequence (output-spec)
+  ;; Check that the given output-spec is a subtype of sequence.  If
+  ;; so, the result is the output-spec.  Give a warning if it's not a
+  ;; sequence specifier.
+  (when (constant-continuation-p output-spec)
+    ;; Only handle constant continuations.
+    (let ((spec (continuation-value output-spec)))
+      (if (subtypep spec 'sequence)
+	  (specifier-type spec)
+	  (compiler-warning "Specified output type ~S is not a sequence type" spec)))))
+
+(defoptimizer (concatenate derive-type) ((output-spec  seq &rest more-seq))
+  ;; The result type of CONCATENATE is OUTPUT-SPEC, but check to see
+  ;; if it makes sense.
+  (output-spec-sequence output-spec))
+
+(defoptimizer (make-sequence derive-type) ((output-spec  seq &rest more-seq))
+  ;; The result type of MAKE-SEQUENCE is OUTPUT-SPEC, but check to see
+  ;; if it makes sense.
+  (output-spec-sequence output-spec))
-- 
GitLab