From 3136fb5bf0f0cbe7efb01c308a9510a62a0909ee Mon Sep 17 00:00:00 2001 From: Douglas Katzman Date: Sat, 19 Sep 2015 21:24:24 -0400 Subject: [PATCH] Make full call of MAP strictly check its output type. --- src/code/quantifiers.lisp | 4 +-- src/code/seq.lisp | 91 ++++++++++++++++++++++++++--------------------- src/compiler/fndb.lisp | 15 ++++---- tests/seq.pure.lisp | 10 ++++++ 4 files changed, 72 insertions(+), 48 deletions(-) diff --git a/src/code/quantifiers.lisp b/src/code/quantifiers.lisp index dbf7e5b3b..2b13b48cd 100644 --- a/src/code/quantifiers.lisp +++ b/src/code/quantifiers.lisp @@ -34,7 +34,7 @@ value found-result)))))) (declare (inline ,wrapper)) - (map nil #',wrapper ,@sequences) + (%map nil #',wrapper ,@sequences) ,unfound-result)))) (values (if bind-fun `(let ,bind-fun ,form) form) nil))))) (macrolet ((defquantifier (name found-test found-result @@ -75,7 +75,7 @@ 'value found-result)))))) (declare (inline map-me)) - (apply #'map nil #'map-me first-seq more-seqs) + (apply #'%map nil #'map-me first-seq more-seqs) ,unfound-result))))) (defquantifier some when :value :unfound-result nil diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 9a75ed48e..915543d43 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -1016,6 +1016,8 @@ many elements are copied." (setf (car in-apply-args) (aref v i) (car in-iters) (1+ i))))) (t + ;; While on one hand this could benefit from a zero-safety ds-bind, + ;; on the other, why not coerce these tuples to vectors or structs? (destructuring-bind (state limit from-end step endp elt &rest ignore) i (declare (type function step endp elt) @@ -1060,10 +1062,17 @@ many elements are copied." ;;; %MAP is just MAP without the final just-to-be-sure check that ;;; length of the output sequence matches any length specified ;;; in RESULT-TYPE. -(defun %map (result-type function first-sequence &rest more-sequences) +(defun %map (result-type function &rest sequences) + (declare (dynamic-extent sequences)) + ;; Everything that we end up calling uses %COERCE-TO-CALLABLE + ;; on FUNCTION so we don't need to declare it of type CALLABLE here. + ;; Additionally all the arity-1 mappers use SEQ-DISPATCH which asserts + ;; that the input is a SEQUENCE. Despite SEQ-DISPATCH being "less safe" + ;; than SEQ-DISPATCH-CHECKING, both are in fact equally safe, because + ;; the ARRAY case (which assumes that all arrays are vectors) utilizes + ;; %WITH-ARRAY-DATA/FP which asserts that its input is a vector. (labels ((slower-map (type) - (let ((really-fun (%coerce-callable-to-fun function)) - (sequences (cons first-sequence more-sequences))) + (let ((really-fun (%coerce-callable-to-fun function))) (cond ((eq type *empty-type*) (%map-for-effect really-fun sequences)) @@ -1073,46 +1082,48 @@ many elements are copied." (%map-to-vector result-type really-fun sequences)) ((and (csubtypep type (specifier-type 'sequence)) (awhen (find-class result-type nil) - (apply #'sb!sequence:map - (sb!mop:class-prototype - (sb!pcl:ensure-class-finalized it)) - really-fun sequences)))) + ;; This function is DEFKNOWNed with EXPLICIT-CHECK, + ;; so we must manually assert that user-written methods + ;; return a subtype of SEQUENCE. + (the sequence + (apply #'sb!sequence:map + (sb!mop:class-prototype + (sb!pcl:ensure-class-finalized it)) + really-fun sequences))))) (t - (bad-sequence-type-error result-type))))) - (slow-map () - (let ((type (specifier-type result-type))) - (cond - (more-sequences - (slower-map type)) - ((eq type *empty-type*) - (%map-for-effect-arity-1 function first-sequence)) - ((csubtypep type (specifier-type 'list)) - (%map-to-list-arity-1 function first-sequence)) - ((or (csubtypep type (specifier-type 'simple-vector)) - (csubtypep type (specifier-type '(vector t)))) - (%map-to-simple-vector-arity-1 function first-sequence)) - (t - (slower-map type)))))) + (bad-sequence-type-error result-type)))))) ;; Handle some easy cases faster - (cond (more-sequences - (slow-map)) - ((null result-type) - (%map-for-effect-arity-1 function first-sequence)) - ((or (eq result-type 'list) - (eq result-type 'cons)) - (%map-to-list-arity-1 function first-sequence)) - ((or (eq result-type 'vector) - (eq result-type 'simple-vector)) - (%map-to-simple-vector-arity-1 function first-sequence)) - (t - (slow-map))))) + (if (/= (length sequences) 1) + (slower-map (specifier-type result-type)) + (let ((first-sequence (fast-&rest-nth 0 sequences))) + (case result-type + ((nil) + (%map-for-effect-arity-1 function first-sequence)) + ((list cons) + (%map-to-list-arity-1 function first-sequence)) + ((vector simple-vector) + (%map-to-simple-vector-arity-1 function first-sequence)) + (t + (let ((type (specifier-type result-type))) + (cond ((eq type *empty-type*) + (%map-for-effect-arity-1 function first-sequence)) + ((csubtypep type (specifier-type 'list)) + (%map-to-list-arity-1 function first-sequence)) + ((csubtypep type (specifier-type '(vector t))) + (%map-to-simple-vector-arity-1 function first-sequence)) + (t + (slower-map type)))))))))) (defun map (result-type function first-sequence &rest more-sequences) - (apply #'%map - result-type - function - first-sequence - more-sequences)) + (let ((result + (apply #'%map result-type function first-sequence more-sequences))) + (if (or (eq result-type 'nil) (typep result result-type)) + result + (error 'simple-type-error + :format-control "MAP result ~S is not a sequence of type ~S" + :datum result + :expected-type result-type + :format-arguments (list result result-type))))) ;;;; MAP-INTO @@ -1123,7 +1134,7 @@ many elements are copied." ;; Note (MAP-INTO SEQ (LAMBDA () ...)) is a different animal, ;; hence the awkward flip between MAP and LOOP. (if ,sequences - (apply #'map nil #'f ,sequences) + (apply #'%map nil #'f ,sequences) (loop (f))))) (define-array-dispatch vector-map-into (data start end fun sequences) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index a50ba1a9b..7608eb3f7 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -522,15 +522,18 @@ (defknown %concatenate-to-base-string (&rest sequence) simple-base-string (explicit-check flushable)) -(defknown (map %map) (type-specifier callable sequence &rest sequence) - consed-sequence - (call) +(defknown map (type-specifier callable sequence &rest sequence) + consed-sequence (call explicit-check) ; :DERIVE-TYPE 'TYPE-SPEC-ARG1 ? Nope... (MAP NIL ...) returns NULL, not NIL. ) -(defknown %map-for-effect-arity-1 (callable sequence) null (call)) -(defknown %map-to-list-arity-1 (callable sequence) list (flushable call)) +(defknown %map (type-specifier callable &rest sequence) + consed-sequence (call explicit-check)) +(defknown %map-for-effect-arity-1 (callable sequence) null + (call explicit-check)) +(defknown %map-to-list-arity-1 (callable sequence) list + (flushable call explicit-check)) (defknown %map-to-simple-vector-arity-1 (callable sequence) simple-vector - (flushable call)) + (flushable call explicit-check)) (defknown map-into (sequence callable &rest sequence) sequence diff --git a/tests/seq.pure.lisp b/tests/seq.pure.lisp index 311b3d65d..dfcc2b332 100644 --- a/tests/seq.pure.lisp +++ b/tests/seq.pure.lisp @@ -416,3 +416,13 @@ (compile nil '(lambda (n) (make-sequence '(vector (integer 1 15) 5) n))))) + +;; Precisely type-check result of full call to MAP. +(with-test (:name :notinlined-map-maximally-safe) + (assert-error + (locally (declare (notinline map)) (map '(cons symbol) '+ '(1 2) '(3 4))) + type-error) + (assert-error + (locally (declare (notinline map)) + (map '(cons t (cons t null)) '+ '(1 2 3) '(10 10 10))) + type-error)) -- 2.11.4.GIT