bare))))))))
;;; Return a DO loop, mapping a function FUN to elements of
-;;; sequences. SEQS is a list of continuations, SEQ-NAMES - list of
-;;; variables, bound to sequences, INTO - a variable, which is used in
+;;; sequences. SEQS is a list of lvars, SEQ-NAMES - list of variables,
+;;; bound to sequences, INTO - a variable, which is used in
;;; MAP-INTO. RESULT and BODY are forms, which can use variables
;;; FUNCALL-RESULT, containing the result of application of FUN, and
;;; INDEX, containing the current position in sequences.
\f
;;;; utilities
-;;; Return true if CONT's only use is a non-NOTINLINE reference to a
+;;; Return true if LVAR's only use is a non-NOTINLINE reference to a
;;; global function with one of the specified NAMES.
(defun lvar-fun-is (lvar names)
(declare (type lvar lvar) (list names))
(not (null (member (leaf-source-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 the
-;;; IR1 transform.
+;;; If LVAR is a constant lvar, 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 (lvar &optional default)
;;; must be SIMPLE-BASE-STRINGs.
(macrolet ((def (name lessp equalp)
`(deftransform ,name ((string1 string2 start1 end1 start2 end2)
- (simple-base-string simple-base-string t t t t) *)
+ (simple-base-string simple-base-string t t t t) *)
`(let* ((end1 (if (not end1) (length string1) end1))
(end2 (if (not end2) (length string2) end2))
(index (sb!impl::%sp-string-compare
string1 start1 end1 string2 start2 end2)))
(if index
- (cond ((= index ,(if ',lessp 'end1 'end2)) index)
- ((= index ,(if ',lessp 'end2 'end1)) nil)
+ (cond ((= index end1)
+ ,(if ',lessp 'index nil))
+ ((= (+ index (- start2 start1)) end2)
+ ,(if ',lessp nil 'index))
((,(if ',lessp 'char< 'char>)
(schar string1 index)
(schar string2
(+ index
(truly-the fixnum
(- start2
- start1))))))
+ start1))))))
index)
- (t nil))
+ (t nil))
,(if ',equalp 'end1 nil))))))
(def string<* t nil)
(def string<=* t t)
;;;; 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.
;;; Moved here from generic/vm-tran.lisp to satisfy clisp
;;;
(def!constant vector-data-bit-offset
(* sb!vm:vector-data-offset sb!vm:n-word-bits))
-(deftransform replace ((string1 string2 &key (start1 0) (start2 0)
- end1 end2)
- (simple-base-string simple-base-string &rest t)
- *
- ;; FIXME: consider replacing this policy test
- ;; with some tests for the STARTx and ENDx
- ;; indices being valid, conditional on high
- ;; SAFETY code.
- ;;
- ;; FIXME: It turns out that this transform is
- ;; critical for the performance of string
- ;; streams. Make this more explicit.
- :policy (< (max safety space) 3))
- `(locally
- (declare (optimize (safety 0)))
- (bit-bash-copy string2
- (the index
- (+ (the index (* start2 sb!vm:n-byte-bits))
- ,vector-data-bit-offset))
- string1
- (the index
- (+ (the index (* start1 sb!vm:n-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:n-byte-bits)))
- string1))
+(eval-when (:compile-toplevel)
+(defun valid-bit-bash-saetp-p (saetp)
+ ;; BIT-BASHing isn't allowed on simple vectors that contain pointers
+ (and (not (eq t (sb!vm:saetp-specifier saetp)))
+ ;; Due to limitations with the current BIT-BASHing code, we can't
+ ;; BIT-BASH reliably on arrays whose element types are larger
+ ;; than the word size.
+ (<= (sb!vm:saetp-n-bits saetp) sb!vm:n-word-bits)))
+) ; EVAL-WHEN
+
+;; FIXME: It turns out that this transform (for SIMPLE-BASE-STRINGS)
+;; is critical for the performance of string streams. Make this
+;; more explicit.
+(macrolet
+ ((define-replace-transforms ()
+ (loop for saetp across sb!vm:*specialized-array-element-type-properties*
+ when (valid-bit-bash-saetp-p saetp)
+ collect
+ (let* ((sequence-type `(simple-array ,(sb!vm:saetp-specifier saetp) (*)))
+ (n-element-bits (sb!vm:saetp-n-bits saetp))
+ (bash-function (intern (format nil "UB~A-BASH-COPY" n-element-bits)
+ (find-package "SB!KERNEL"))))
+ `(deftransform replace ((seq1 seq2 &key (start1 0) (start2 0) end1 end2)
+ (,sequence-type ,sequence-type &rest t)
+ ,sequence-type
+ :node node)
+ `(let* ((len1 (length seq1))
+ (len2 (length seq2))
+ (end1 (or end1 len1))
+ (end2 (or end2 len2))
+ (replace-len1 (- end1 start1))
+ (replace-len2 (- end2 start2)))
+ ,(unless (policy node (= safety 0))
+ `(progn
+ (unless (<= 0 start1 end1 len1)
+ (sb!impl::signal-bounding-indices-bad-error seq1 start1 end1))
+ (unless (<= 0 start2 end2 len2)
+ (sb!impl::signal-bounding-indices-bad-error seq2 start2 end2))))
+ (funcall (function ,',bash-function)
+ seq2 start2
+ seq1 start1
+ (min replace-len1 replace-len2))
+ seq1)))
+ into forms
+ finally (return `(progn ,@forms)))))
+ (define-replace-transforms))
+
+(macrolet
+ ((define-subseq-transforms ()
+ (loop for saetp across sb!vm:*specialized-array-element-type-properties*
+ when (valid-bit-bash-saetp-p saetp)
+ collect
+ (let* ((sequence-type `(simple-array ,(sb!vm:saetp-specifier saetp) (*)))
+ (n-element-bits (sb!vm:saetp-n-bits saetp))
+ (bash-function (intern (format nil "UB~A-BASH-COPY" n-element-bits)
+ (find-package "SB!KERNEL"))))
+ `(deftransform subseq ((seq start &optional end)
+ (,sequence-type t &optional t)
+ ,sequence-type :node node)
+ `(let* ((length (length seq))
+ (end (if end (min end length) length)))
+ ,(unless (policy node (= safety 0))
+ `(progn
+ (unless (<= 0 start end length)
+ (sb!impl::signal-bounding-indices-bad-error seq start end))))
+ (let* ((size (- end start))
+ (result (make-array size :element-type ',',(sb!vm:saetp-specifier saetp))))
+ (funcall (function ,',bash-function)
+ seq start result 0 size)
+ result))))
+ into forms
+ finally (return `(progn ,@forms)))))
+ (define-subseq-transforms))
+
+(macrolet
+ ((define-copy-seq-transforms ()
+ (loop for saetp across sb!vm:*specialized-array-element-type-properties*
+ when (valid-bit-bash-saetp-p saetp)
+ collect
+ (let* ((sequence-type `(simple-array ,(sb!vm:saetp-specifier saetp) (*)))
+ (n-element-bits (sb!vm:saetp-n-bits saetp))
+ (bash-function (intern (format nil "UB~A-BASH-COPY" n-element-bits)
+ (find-package "SB!KERNEL"))))
+ `(deftransform copy-seq ((seq) (,sequence-type)
+ ,sequence-type)
+ `(let* ((length (length seq))
+ (result (make-array length :element-type ',',(sb!vm:saetp-specifier saetp))))
+ (funcall (function ,',bash-function)
+ seq 0 result 0 length)
+ result)))
+ into forms
+ finally (return `(progn ,@forms)))))
+ (define-copy-seq-transforms))
+
+;;; FIXME: this would be a valid transform for certain excluded cases:
+;;; * :TEST 'CHAR= or :TEST #'CHAR=
+;;; * :TEST 'EQL or :TEST #'EQL
+;;; * :FROM-END NIL (or :FROM-END non-NIL, with a little ingenuity)
+(deftransform search ((pattern text &key (start1 0) (start2 0) end1 end2)
+ (simple-string simple-string &rest t)
+ *
+ :policy (> speed (max space safety)))
+ `(block search
+ (let ((end1 (or end1 (length pattern)))
+ (end2 (or end2 (length text))))
+ (do ((index2 start2 (1+ index2)))
+ ((>= index2 end2) nil)
+ (when (do ((index1 start1 (1+ index1))
+ (index2 index2 (1+ index2)))
+ ((>= index1 end1) t)
+ (when (= index2 end2)
+ (return-from search nil))
+ (when (char/= (char pattern index1) (char text index2))
+ (return nil)))
+ (return index2))))))
;;; FIXME: It seems as though it should be possible to make a DEFUN
;;; %CONCATENATE (with a DEFTRANSFORM to translate constant RTYPE to
;;; at least once DYNAMIC-EXTENT works.
;;;
;;; FIXME: currently KLUDGEed because of bug 188
+;;;
+;;; FIXME: disabled for sb-unicode: probably want it back
+#!-sb-unicode
(deftransform concatenate ((rtype &rest sequences)
(t &rest (or simple-base-string
(simple-array nil (*))))
(declare (ignore rtype))
(let* (,@lets
(res (make-string (truncate (the index (+ ,@all-lengths))
- sb!vm:n-byte-bits))))
+ sb!vm:n-byte-bits)
+ :element-type 'base-char)))
(declare (type index ,@all-lengths))
(let (,@(mapcar (lambda (name) `(,name 0)) starts))
(declare (type index ,@starts))
`(deftransform ,name ((predicate sequence from-end start end key)
(function list t t t function)
*
- :policy (> speed space)
- :important t)
+ :policy (> speed space))
"expand inline"
`(let ((index 0)
(find nil)
(deftransform %find-position ((item sequence from-end start end key test)
(t list t t t t t)
*
- :policy (> speed space)
- :important t)
+ :policy (> speed space))
"expand inline"
'(%find-position-if (let ((test-fun (%coerce-callable-to-fun test)))
;; The order of arguments for asymmetric tests
(deftransform %find-position-if ((predicate sequence from-end start end key)
(function vector t t t function)
*
- :policy (> speed space)
- :important t)
+ :policy (> speed space))
"expand inline"
(check-inlineability-of-find-position-if sequence from-end)
'(%find-position-if-vector-macro predicate sequence
(deftransform %find-position-if-not ((predicate sequence from-end start end key)
(function vector t t t function)
*
- :policy (> speed space)
- :important t)
+ :policy (> speed space))
"expand inline"
(check-inlineability-of-find-position-if sequence from-end)
'(%find-position-if-not-vector-macro predicate sequence
(deftransform %find-position ((item sequence from-end start end key test)
(t vector t t t function function)
*
- :policy (> speed space)
- :important t)
+ :policy (> speed space))
"expand inline"
(check-inlineability-of-find-position-if sequence from-end)
'(%find-position-vector-macro item sequence
;;; perhaps it's worth optimizing the -if-not versions in the same
;;; way as the others?
;;;
-;;; FIXME: Maybe remove uses of these deprecated functions (and
-;;; definitely of :TEST-NOT) within the implementation of SBCL.
+;;; FIXME: Maybe remove uses of these deprecated functions within the
+;;; implementation of SBCL.
(macrolet ((define-find-position-if-not (fun-name values-index)
`(deftransform ,fun-name ((predicate sequence &key
from-end (start 0)
projects / sbcl.git / blobdiff