X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fseqtran.lisp;h=b531b36516d67e852f03b75037007f5cf4f6d417;hb=6053e7f804b430144bb09e2d107ad4ab3fb97db4;hp=acaef21ac1a09af29b0b29e9f6be0c810e1acbb9;hpb=e795ac27a9780a35a7d561bfe34d7df224958fbd;p=sbcl.git diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index acaef21..b531b36 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -44,13 +44,14 @@ `(let ((,fn-sym ,fn) (,map-result (list nil))) (do-anonymous ((,temp ,map-result) . ,(do-clauses)) - (,endtest (cdr ,map-result)) + (,endtest (truly-the list (cdr ,map-result))) (rplacd ,temp (setq ,temp (list ,call))))))) ((nil) `(let ((,fn-sym ,fn) (,n-first ,(first arglists))) (do-anonymous ,(do-clauses) - (,endtest ,n-first) ,call)))))))) + (,endtest (truly-the list ,n-first)) + ,call)))))))) (define-source-transform mapc (function list &rest more-lists) (mapfoo-transform function (cons list more-lists) nil t)) @@ -75,17 +76,17 @@ ;;; MAP is %MAP plus a check to make sure that any length specified in ;;; the result type matches the actual result. We also wrap it in a ;;; TRULY-THE for the most specific type we can determine. -(deftransform map ((result-type-arg fun &rest seqs) * * :node node) - (let* ((seq-names (make-gensym-list (length seqs))) +(deftransform map ((result-type-arg fun seq &rest seqs) * * :node node) + (let* ((seq-names (make-gensym-list (1+ (length seqs)))) (bare `(%map result-type-arg fun ,@seq-names)) - (constant-result-type-arg-p (constant-continuation-p result-type-arg)) + (constant-result-type-arg-p (constant-lvar-p result-type-arg)) ;; what we know about the type of the result. (Note that the ;; "result type" argument is not necessarily the type of the ;; result, since NIL means the result has NULL type.) (result-type (if (not constant-result-type-arg-p) 'consed-sequence (let ((result-type-arg-value - (continuation-value result-type-arg))) + (lvar-value result-type-arg))) (if (null result-type-arg-value) 'null result-type-arg-value))))) @@ -121,8 +122,8 @@ 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. @@ -130,7 +131,7 @@ (declare (type list seqs seq-names) (type symbol into)) (collect ((bindings) - (declarations) + (declarations) (vector-lengths) (tests) (places)) @@ -141,11 +142,11 @@ (bindings `(index 0 (1+ index))) (declarations `(type index index))) (vector-lengths length))) - (loop for seq of-type continuation in seqs + (loop for seq of-type lvar in seqs for seq-name in seq-names - for type = (continuation-type seq) + for type = (lvar-type seq) do (cond ((csubtypep type (specifier-type 'list)) - (let ((index (gensym "I"))) + (with-unique-names (index) (bindings `(,index ,seq-name (cdr ,index))) (declarations `(type list ,index)) (places `(car ,index)) @@ -180,10 +181,10 @@ ;;; handle that case more efficiently, but it's left as an exercise to ;;; the reader, because the code is complicated enough already and I ;;; don't happen to need that functionality right now. -- WHN 20000410 -(deftransform %map ((result-type fun &rest seqs) * * :policy (>= speed space)) +(deftransform %map ((result-type fun seq &rest seqs) * * + :policy (>= speed space)) "open code" - (unless seqs (abort-ir1-transform "no sequence args")) - (unless (constant-continuation-p result-type) + (unless (constant-lvar-p result-type) (give-up-ir1-transform "RESULT-TYPE argument not constant")) (labels ( ;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true (fn-1subtypep (fn x y) @@ -193,7 +194,7 @@ (give-up-ir1-transform "can't analyze sequence type relationship")))) (1subtypep (x y) (fn-1subtypep #'sb!xc:subtypep x y))) - (let* ((result-type-value (continuation-value result-type)) + (let* ((result-type-value (lvar-value result-type)) (result-supertype (cond ((null result-type-value) 'null) ((1subtypep result-type-value 'vector) 'vector) @@ -202,24 +203,25 @@ (t (give-up-ir1-transform "can't determine result type"))))) - (cond ((and result-type-value (= 1 (length seqs))) + (cond ((and result-type-value (null seqs)) ;; The consing arity-1 cases can be implemented ;; reasonably efficiently as function calls, and the cost ;; of consing should be significantly larger than ;; function call overhead, so we always compile these ;; cases as full calls regardless of speed-versus-space ;; optimization policy. - (cond ((subtypep 'list result-type-value) - '(apply #'%map-to-list-arity-1 fun seqs)) + (cond ((subtypep result-type-value 'list) + '(%map-to-list-arity-1 fun seq)) ( ;; (This one can be inefficient due to COERCE, but ;; the current open-coded implementation has the ;; same problem.) (subtypep result-type-value 'vector) - `(coerce (apply #'%map-to-simple-vector-arity-1 fun seqs) + `(coerce (%map-to-simple-vector-arity-1 fun seq) ',result-type-value)) (t (bug "impossible (?) sequence type")))) (t - (let* ((seq-args (make-gensym-list (length seqs)))) + (let* ((seqs (cons seq seqs)) + (seq-args (make-gensym-list (length seqs)))) (multiple-value-bind (push-dacc result) (ecase result-supertype (null (values nil nil)) @@ -291,10 +293,10 @@ (macrolet ((def (name) `(deftransform ,name ((e l &key (test #'eql)) * * :node node) - (unless (constant-continuation-p l) + (unless (constant-lvar-p l) (give-up-ir1-transform)) - (let ((val (continuation-value l))) + (let ((val (lvar-value l))) (unless (policy node (or (= speed 3) (and (>= speed space) @@ -328,9 +330,9 @@ ;; if ITEM is not a NUMBER or is a FIXNUM, apply ;; transform, else give up on transform. (cond (test - (unless (continuation-fun-is test '(eq)) + (unless (lvar-fun-is test '(eq)) (give-up-ir1-transform))) - ((types-equal-or-intersect (continuation-type item) + ((types-equal-or-intersect (lvar-type item) (specifier-type 'number)) (give-up-ir1-transform "Item might be a number."))) `(,',eq-fun item list)))) @@ -374,11 +376,11 @@ ;;;; 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 continuation-fun-is (cont names) - (declare (type continuation cont) (list names)) - (let ((use (continuation-use cont))) +(defun lvar-fun-is (lvar names) + (declare (type lvar lvar) (list names)) + (let ((use (lvar-uses lvar))) (and (ref-p use) (let ((leaf (ref-leaf use))) (and (global-var-p leaf) @@ -386,16 +388,16 @@ (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 (cont &optional default) - (declare (type (or continuation null) cont)) - (cond ((not cont) default) - ((constant-continuation-p cont) - (continuation-value cont)) +(defun constant-value-or-lose (lvar &optional default) + (declare (type (or lvar null) lvar)) + (cond ((not lvar) default) + ((constant-lvar-p lvar) + (lvar-value lvar)) (t (give-up-ir1-transform)))) @@ -567,7 +569,7 @@ (specifier-type 'function))) (when (policy *compiler-error-context* (> speed inhibit-warnings)) - (compiler-note + (compiler-notify "~S may not be a function, so must coerce at run-time." n-fun)) (once-only ((n-fun `(if (functionp ,n-fun) @@ -619,10 +621,10 @@ ;;; Return a form that tests the free variables STRING1 and STRING2 ;;; for the ordering relationship specified by LESSP and EQUALP. The ;;; start and end are also gotten from the environment. Both strings -;;; must be SIMPLE-STRINGs. +;;; must be SIMPLE-BASE-STRINGs. (macrolet ((def (name lessp equalp) `(deftransform ,name ((string1 string2 start1 end1 start2 end2) - (simple-string simple-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 @@ -648,7 +650,7 @@ (macrolet ((def (name result-fun) `(deftransform ,name ((string1 string2 start1 end1 start2 end2) - (simple-string simple-string t t t t) *) + (simple-base-string simple-base-string t t t t) *) `(,',result-fun (sb!impl::%sp-string-compare string1 start1 (or end1 (length string1)) @@ -681,7 +683,7 @@ (deftransform replace ((string1 string2 &key (start1 0) (start2 0) end1 end2) - (simple-string simple-string &rest t) + (simple-base-string simple-base-string &rest t) * ;; FIXME: consider replacing this policy test ;; with some tests for the STARTx and ENDx @@ -717,41 +719,43 @@ ;;; ;;; FIXME: currently KLUDGEed because of bug 188 (deftransform concatenate ((rtype &rest sequences) - (t &rest simple-string) - simple-string + (t &rest (or simple-base-string + (simple-array nil (*)))) + simple-base-string :policy (< safety 3)) - (collect ((lets) - (forms) - (all-lengths) - (args)) - (dolist (seq sequences) - (declare (ignorable seq)) - (let ((n-seq (gensym)) - (n-length (gensym))) - (args n-seq) - (lets `(,n-length (the index (* (length ,n-seq) sb!vm:n-byte-bits)))) - (all-lengths n-length) - (forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset - res start - ,n-length)) - (forms `(setq start (opaque-identity (+ start ,n-length)))))) - `(lambda (rtype ,@(args)) - (declare (ignore rtype)) - ;; KLUDGE - (flet ((opaque-identity (x) x)) - (declare (notinline opaque-identity)) - (let* (,@(lets) - (res (make-string (truncate (the index (+ ,@(all-lengths))) - sb!vm:n-byte-bits))) - (start ,vector-data-bit-offset)) - (declare (type index start ,@(all-lengths))) - ,@(forms) - res))))) + (loop for rest-seqs on sequences + for n-seq = (gensym "N-SEQ") + for n-length = (gensym "N-LENGTH") + for start = vector-data-bit-offset then next-start + for next-start = (gensym "NEXT-START") + collect n-seq into args + collect `(,n-length (* (length ,n-seq) sb!vm:n-byte-bits)) into lets + collect n-length into all-lengths + collect next-start into starts + collect `(if (and (typep ,n-seq '(simple-array nil (*))) + (> ,n-length 0)) + (error 'nil-array-accessed-error) + (bit-bash-copy ,n-seq ,vector-data-bit-offset + res ,start ,n-length)) + into forms + collect `(setq ,next-start (+ ,start ,n-length)) into forms + finally + (return + `(lambda (rtype ,@args) + (declare (ignore rtype)) + (let* (,@lets + (res (make-string (truncate (the index (+ ,@all-lengths)) + sb!vm:n-byte-bits)))) + (declare (type index ,@all-lengths)) + (let (,@(mapcar (lambda (name) `(,name 0)) starts)) + (declare (type index ,@starts)) + ,@forms) + res))))) ;;;; CONS accessor DERIVE-TYPE optimizers (defoptimizer (car derive-type) ((cons)) - (let ((type (continuation-type cons)) + (let ((type (lvar-type cons)) (null-type (specifier-type 'null))) (cond ((eq type null-type) null-type) @@ -759,7 +763,7 @@ (cons-type-car-type type))))) (defoptimizer (cdr derive-type) ((cons)) - (let ((type (continuation-type cons)) + (let ((type (lvar-type cons)) (null-type (specifier-type 'null))) (cond ((eq type null-type) null-type) @@ -772,12 +776,12 @@ ;;; %FIND-POSITION-IF only when %FIND-POSITION-IF has an inline ;;; expansion, so we factor out the condition into this function. (defun check-inlineability-of-find-position-if (sequence from-end) - (let ((ctype (continuation-type sequence))) + (let ((ctype (lvar-type sequence))) (cond ((csubtypep ctype (specifier-type 'vector)) ;; It's not worth trying to inline vector code unless we ;; know a fair amount about it at compile time. (upgraded-element-type-specifier-or-give-up sequence) - (unless (constant-continuation-p from-end) + (unless (constant-lvar-p from-end) (give-up-ir1-transform "FROM-END argument value not known at compile time"))) ((csubtypep ctype (specifier-type 'list)) @@ -832,7 +836,7 @@ (incf index)))))) (def %find-position-if when) (def %find-position-if-not unless)) - + ;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF ;;; without loss of efficiency. (I.e., the optimizer should be able ;;; to straighten everything out.) @@ -865,13 +869,7 @@ end-arg element done-p-expr) - (let ((offset (gensym "OFFSET")) - (block (gensym "BLOCK")) - (index (gensym "INDEX")) - (n-sequence (gensym "N-SEQUENCE-")) - (sequence (gensym "SEQUENCE")) - (n-end (gensym "N-END-")) - (end (gensym "END-"))) + (with-unique-names (offset block index n-sequence sequence n-end end) `(let ((,n-sequence ,sequence-arg) (,n-end ,end-arg)) (with-array-data ((,sequence ,n-sequence :offset-var ,offset) @@ -900,7 +898,7 @@ (def!macro %find-position-vector-macro (item sequence from-end start end key test) - (let ((element (gensym "ELEMENT"))) + (with-unique-names (element) (%find-position-or-find-position-if-vector-expansion sequence from-end @@ -914,7 +912,7 @@ (def!macro %find-position-if-vector-macro (predicate sequence from-end start end key) - (let ((element (gensym "ELEMENT"))) + (with-unique-names (element) (%find-position-or-find-position-if-vector-expansion sequence from-end @@ -925,7 +923,7 @@ (def!macro %find-position-if-not-vector-macro (predicate sequence from-end start end key) - (let ((element (gensym "ELEMENT"))) + (with-unique-names (element) (%find-position-or-find-position-if-vector-expansion sequence from-end