X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=7fc4474106f28cff0e78c440f6f28b89b9d60e5f;hb=993d5b779638756473181dda8d928d33038d4cc3;hp=8c493b121cda7ab07f524f541f6ddd04184b4c3d;hpb=19198944c81507369ae46522c13b30df628cb442;p=sbcl.git

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 8c493b1..7fc4474 100644
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -322,13 +322,13 @@
 
 ;;; names of predicates that compute the same value as CHAR= when
 ;;; applied to characters
-(defconstant char=-functions '(eql equal char=))
+(defparameter *char=-functions* '(eql equal char=))
 
 (deftransform search ((string1 string2 &key (start1 0) end1 (start2 0) end2
 			       test)
 		      (simple-string simple-string &rest t))
   (unless (or (not test)
-	      (continuation-function-is test char=-functions))
+	      (continuation-function-is test *char=-functions*))
     (give-up-ir1-transform))
   '(sb!impl::%sp-string-search string1 start1 (or end1 (length string1))
 			       string2 start2 (or end2 (length string2))))
@@ -336,7 +336,7 @@
 (deftransform position ((item sequence &key from-end test (start 0) end)
 			(t simple-string &rest t))
   (unless (or (not test)
-	      (continuation-function-is test char=-functions))
+	      (continuation-function-is test *char=-functions*))
     (give-up-ir1-transform))
   `(and (typep item 'character)
 	(,(if (constant-value-or-lose from-end)
@@ -355,8 +355,8 @@
 
 ;;;; utilities
 
-;;; Return true if Cont's only use is a non-notinline reference to a global
-;;; function with one of the specified Names.
+;;; Return true if CONT's only use is a non-notinline reference to a
+;;; global function with one of the specified NAMES.
 (defun continuation-function-is (cont names)
   (declare (type continuation cont) (list names))
   (let ((use (continuation-use cont)))
@@ -366,8 +366,10 @@
 		(eq (global-var-kind leaf) :global-function)
 		(not (null (member (leaf-name leaf) names :test #'equal))))))))
 
-;;; If Cont is a constant continuation, the return the constant value. If
-;;; it is null, then return default, otherwise quietly GIVE-UP.
+;;; If CONT is a constant continuation, the return the constant value.
+;;; If it is null, then return default, otherwise quietly give up the
+;;; IR1 transform.
+;;;
 ;;; ### Probably should take an ARG and flame using the NAME.
 (defun constant-value-or-lose (cont &optional default)
   (declare (type (or continuation null) cont))
@@ -378,10 +380,10 @@
 	 (give-up-ir1-transform))))
 
 #|
-;;; This is a frob whose job it is to make it easier to pass around the
-;;; arguments to IR1 transforms. It bundles together the name of the argument
-;;; (which should be referenced in any expansion), and the continuation for
-;;; that argument (or NIL if unsupplied.)
+;;; This is a frob whose job it is to make it easier to pass around
+;;; the arguments to IR1 transforms. It bundles together the name of
+;;; the argument (which should be referenced in any expansion), and
+;;; the continuation for that argument (or NIL if unsupplied.)
 (defstruct (arg (:constructor %make-arg (name cont)))
   (name nil :type symbol)
   (cont nil :type (or continuation null)))
@@ -539,7 +541,8 @@
 		   ,body))
 	       ((not (csubtypep (continuation-type fun-cont)
 				(specifier-type 'function)))
-		(when (policy *compiler-error-context* (> speed brevity))
+		(when (policy *compiler-error-context*
+			      (> speed inhibit-warnings))
 		  (compiler-note
 		   "~S may not be a function, so must coerce at run-time."
 		   n-fun))
@@ -704,3 +707,21 @@
 	 (declare (type index start ,@(all-lengths)))
 	 ,@(forms)
 	 res))))
+
+;;;; CONS accessor DERIVE-TYPE optimizers
+
+(defoptimizer (car derive-type) ((cons))
+  (let ((type (continuation-type cons))
+	(null-type (specifier-type 'null)))
+    (cond ((eq type null-type)
+	   null-type)
+	  ((cons-type-p type)
+	   (cons-type-car-type type)))))
+
+(defoptimizer (cdr derive-type) ((cons))
+  (let ((type (continuation-type cons))
+	(null-type (specifier-type 'null)))
+    (cond ((eq type null-type)
+	   null-type)
+	  ((cons-type-p type)
+	   (cons-type-cdr-type type)))))