;;; 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))))
(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)
\f
;;;; 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)))
(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))
(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)))
,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))
(sb!impl::%sp-string-compare
string1 start1 (or end1 (length string1))
string2 start2 (or end2 (length string2)))))))
+\f
+;;;; string-only transforms for sequence functions
+;;;;
+;;;; Note: CMU CL had more of these, including transforms for
+;;;; functions which cons. In SBCL, we've gotten rid of most of the
+;;;; transforms for functions which cons, since our GC overhead is
+;;;; sufficiently large that it doesn't seem worth it to try to
+;;;; economize on function call overhead or on the overhead of runtime
+;;;; type dispatch in AREF. The exception is CONCATENATE, since
+;;;; a full call to CONCATENATE would have to look up the sequence
+;;;; type, which can be really slow.
+;;;;
+;;;; FIXME: It would be nicer for these transforms to work for any
+;;;; calls when all arguments are vectors with the same element type,
+;;;; rather than restricting them to STRINGs only.
+
+;;; FIXME: Shouldn't we be testing for legality of
+;;; * START1, START2, END1, and END2 indices?
+;;; * size of copied string relative to destination string?
+;;; (Either there should be tests conditional on SAFETY>=SPEED, or
+;;; the transform should be conditional on SPEED>SAFETY.)
+;;;
+;;; FIXME: Also, the transform should probably be dependent on
+;;; SPEED>SPACE.
+(deftransform replace ((string1 string2 &key (start1 0) (start2 0)
+ end1 end2)
+ (simple-string simple-string &rest t))
+ `(locally
+ (declare (optimize (safety 0)))
+ (bit-bash-copy string2
+ (the index
+ (+ (the index (* start2 sb!vm:byte-bits))
+ ,vector-data-bit-offset))
+ string1
+ (the index
+ (+ (the index (* start1 sb!vm:byte-bits))
+ ,vector-data-bit-offset))
+ (the index
+ (* (min (the index (- (or end1 (length string1))
+ start1))
+ (the index (- (or end2 (length string2))
+ start2)))
+ sb!vm:byte-bits)))
+ string1))
+
+;;; FIXME: It seems as though it should be possible to make a DEFUN
+;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to
+;;; CTYPE before calling %CONCATENATE) which is comparably efficient,
+;;; at least once DYNAMIC-EXTENT works.
+(deftransform concatenate ((rtype &rest sequences)
+ (t &rest simple-string)
+ simple-string)
+ (collect ((lets)
+ (forms)
+ (all-lengths)
+ (args))
+ (dolist (seq sequences)
+ (declare (ignore seq))
+ (let ((n-seq (gensym))
+ (n-length (gensym)))
+ (args n-seq)
+ (lets `(,n-length (the index (* (length ,n-seq) sb!vm:byte-bits))))
+ (all-lengths n-length)
+ (forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset
+ res start
+ ,n-length))
+ (forms `(setq start (+ start ,n-length)))))
+ `(lambda (rtype ,@(args))
+ (declare (ignore rtype))
+ (let* (,@(lets)
+ (res (make-string (truncate (the index (+ ,@(all-lengths)))
+ sb!vm:byte-bits)))
+ (start ,vector-data-bit-offset))
+ (declare (type index start ,@(all-lengths)))
+ ,@(forms)
+ res))))
+\f
+;;;; 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)))))
projects / sbcl.git / blobdiff