From 06cb0db045562ab583358e2ee7090c606e1dfe42 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Fri, 20 Oct 2000 18:05:09 +0000 Subject: [PATCH] 0.6.7.19: added stop-compiler-crash patch from Martin Atzmueller --- NEWS | 9 +- src/code/array.lisp | 83 ++++++------ src/compiler/generic/vm-tran.lisp | 7 + src/compiler/locall.lisp | 257 +++++++++++++++++++------------------ tests/compiler.pure.lisp | 27 ++++ tests/pcl.impure.lisp | 4 + tests/run-tests.sh | 30 ++++- tests/vector.pure.lisp | 24 ++-- version.lisp-expr | 2 +- 9 files changed, 258 insertions(+), 185 deletions(-) create mode 100644 tests/compiler.pure.lisp diff --git a/NEWS b/NEWS index ff049ff..39c10e5 100644 --- a/NEWS +++ b/NEWS @@ -504,9 +504,12 @@ changes in sbcl-0.6.8 relative to sbcl-0.6.7: used to not be called for a saved Lisp image.) ?? The patch for the SUBSEQ bug reported on the cmucl-imp mailing list 12 September 2000 has been applied to SBCL. -?? Martin Atzmueller's versions of two CMU CL patches, as posted on - sbcl-devel 13 September 2000, have been installed. (The patches fix - a bug in SUBSEQ and .) +?? Martin Atzmueller's version of a patch to fix a compiler crash, + as posted on sbcl-devel 13 September 2000, has been installed. +?? Instead of installing Martin Atzmueller's patch for the + compiler transform for SUBSEQ, I deleted the compiler transform, + and transforms for some similar consing operations (CONCATENATE + ?? A bug in signal handling which kept TRACE from working on OpenBSD has been fixed. ?? Remember to remove this from the port-specific section of BUGS. diff --git a/src/code/array.lisp b/src/code/array.lisp index 69d0e4f..603ad6e 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -187,7 +187,7 @@ (null displaced-to)))) (declare (fixnum array-rank)) (when (and displaced-index-offset (null displaced-to)) - (error "Can't specify :displaced-index-offset without :displaced-to")) + (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO")) (if (and simple (= array-rank 1)) ;; Its a (simple-array * (*)) (multiple-value-bind (type bits) (%vector-type-code element-type) @@ -207,11 +207,11 @@ (fill array initial-element)) (when initial-contents (when initial-element - (error "Cannot specify both :initial-element and ~ - :initial-contents")) + (error "can't specify both :INITIAL-ELEMENT and ~ + :INITIAL-CONTENTS")) (unless (= length (length initial-contents)) - (error "~D elements in the initial-contents, but the ~ - vector length is ~D." + (error "There are ~D elements in the :INITIAL-CONTENTS, but ~ + the vector length is ~D." (length initial-contents) length)) (replace array initial-contents)) @@ -240,7 +240,7 @@ (unless (and (fixnump fill-pointer) (>= fill-pointer 0) (<= fill-pointer length)) - (error "Invalid fill-pointer ~D" + (error "invalid fill-pointer ~D" fill-pointer)) fill-pointer)))) (setf (%array-fill-pointer-p array) t)) @@ -251,8 +251,8 @@ (setf (%array-data-vector array) data) (cond (displaced-to (when (or initial-element-p initial-contents) - (error "Neither :initial-element nor :initial-contents ~ - can be specified along with :displaced-to")) + (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~ + can be specified along with :DISPLACED-TO")) (let ((offset (or displaced-index-offset 0))) (when (> (+ offset total-size) (array-total-size displaced-to)) @@ -267,15 +267,16 @@ (incf axis))) array)))) -;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the specified array -;;; characteristics. Dimensions is only used to pass to FILL-DATA-VECTOR -;;; for error checking on the structure of initial-contents. +;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the +;;; specified array characteristics. Dimensions is only used to pass +;;; to FILL-DATA-VECTOR for error checking on the structure of +;;; initial-contents. (defun data-vector-from-inits (dimensions total-size element-type initial-contents initial-element initial-element-p) (when (and initial-contents initial-element-p) - (error "Cannot supply both :initial-contents and :initial-element to - either make-array or adjust-array.")) + (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to + either MAKE-ARRAY or ADJUST-ARRAY.")) (let ((data (if initial-element-p (make-array total-size :element-type element-type @@ -300,12 +301,12 @@ (incf index)) (t (unless (typep contents 'sequence) - (error "Malformed :INITIAL-CONTENTS. ~S is not a ~ + (error "malformed :INITIAL-CONTENTS: ~S is not a ~ sequence, but ~D more layer~:P needed." contents (- (length dimensions) axis))) (unless (= (length contents) (car dims)) - (error "Malformed :INITIAL-CONTENTS. Dimension of ~ + (error "malformed :INITIAL-CONTENTS: Dimension of ~ axis ~D is ~D, but ~S is ~D long." axis (car dims) contents (length contents))) (if (listp contents) @@ -392,7 +393,7 @@ (list subscripts)) (let ((rank (array-rank array))) (unless (= rank (length subscripts)) - (error "Wrong number of subscripts, ~D, for array of rank ~D" + (error "wrong number of subscripts, ~D, for array of rank ~D" (length subscripts) rank)) (if (array-header-p array) (do ((subs (nreverse subscripts) (cdr subs)) @@ -406,7 +407,7 @@ (declare (fixnum index dim)) (unless (< -1 index dim) (if invalid-index-error-p - (error "Invalid index ~D~[~;~:; on axis ~:*~D~] in ~S" + (error "invalid index ~D~[~;~:; on axis ~:*~D~] in ~S" index axis array) (return-from %array-row-major-index nil))) (incf result (* chunk-size index)) @@ -414,7 +415,7 @@ (let ((index (first subscripts))) (unless (< -1 index (length (the (simple-array * (*)) array))) (if invalid-index-error-p - (error "Invalid index ~D in ~S" index array) + (error "invalid index ~D in ~S" index array) (return-from %array-row-major-index nil))) index)))) @@ -596,7 +597,7 @@ (error "Vector axis is not zero: ~S" axis-number)) (length (the (simple-array * (*)) array))) ((>= axis-number (%array-rank array)) - (error "~D is too big; ~S only has ~D dimension~:P" + (error "~D is too big; ~S only has ~D dimension~:P." axis-number array (%array-rank array))) (t (%array-dimension array axis-number)))) @@ -708,7 +709,7 @@ (let ((fill-pointer (fill-pointer array))) (declare (fixnum fill-pointer)) (if (zerop fill-pointer) - (error "Nothing left to pop.") + (error "There is nothing left to pop.") (aref array (setf (%array-fill-pointer array) (1- fill-pointer)))))) @@ -725,9 +726,9 @@ (let ((dimensions (if (listp dimensions) dimensions (list dimensions)))) (cond ((/= (the fixnum (length (the list dimensions))) (the fixnum (array-rank array))) - (error "Number of dimensions not equal to rank of array.")) + (error "The number of dimensions not equal to rank of array.")) ((not (subtypep element-type (array-element-type array))) - (error "New element type, ~S, is incompatible with old." + (error "The new element type, ~S, is incompatible with old type." element-type))) (let ((array-rank (length (the list dimensions)))) (declare (fixnum array-rank)) @@ -737,7 +738,7 @@ ;; Array former contents replaced by initial-contents. (if (or initial-element-p displaced-to) (error "Initial contents may not be specified with ~ - the :initial-element or :displaced-to option.")) + the :INITIAL-ELEMENT or :DISPLACED-TO option.")) (let* ((array-size (apply #'* dimensions)) (array-data (data-vector-from-inits dimensions array-size element-type @@ -757,25 +758,25 @@ (displaced-to ;; No initial-contents supplied is already established. (when initial-element - (error "The :initial-element option may not be specified ~ - with :displaced-to.")) + (error "The :INITIAL-ELEMENT option may not be specified ~ + with :DISPLACED-TO.")) (unless (subtypep element-type (array-element-type displaced-to)) - (error "One can't displace an array of type ~S into another of ~ - type ~S." + (error "can't displace an array of type ~S into another of ~ + type ~S" element-type (array-element-type displaced-to))) (let ((displacement (or displaced-index-offset 0)) (array-size (apply #'* dimensions))) (declare (fixnum displacement array-size)) (if (< (the fixnum (array-total-size displaced-to)) (the fixnum (+ displacement array-size))) - (error "The :displaced-to array is too small.")) + (error "The :DISPLACED-TO array is too small.")) (if (adjustable-array-p array) ;; None of the original contents appear in adjusted array. (set-array-header array displaced-to array-size (get-new-fill-pointer array array-size fill-pointer) displacement dimensions t) - ;; Simple multidimensional or single dimensional array. + ;; simple multidimensional or single dimensional array (make-array dimensions :element-type element-type :displaced-to displaced-to @@ -833,26 +834,26 @@ (cond ((not fill-pointer) (when (array-has-fill-pointer-p old-array) (when (> (%array-fill-pointer old-array) new-array-size) - (error "Cannot adjust-array an array (~S) to a size (~S) that is ~ - smaller than its fill pointer (~S)." + (error "cannot ADJUST-ARRAY an array (~S) to a size (~S) that is ~ + smaller than its fill pointer (~S)" old-array new-array-size (fill-pointer old-array))) (%array-fill-pointer old-array))) ((not (array-has-fill-pointer-p old-array)) - (error "Cannot supply a non-NIL value (~S) for :fill-pointer ~ - in adjust-array unless the array (~S) was originally ~ - created with a fill pointer." - fill-pointer - old-array)) + (error "cannot supply a non-NIL value (~S) for :FILL-POINTER ~ + in ADJUST-ARRAY unless the array (~S) was originally ~ + created with a fill pointer" + fill-pointer + old-array)) ((numberp fill-pointer) (when (> fill-pointer new-array-size) - (error "Cannot supply a value for :fill-pointer (~S) that is larger ~ + (error "can't supply a value for :FILL-POINTER (~S) that is larger ~ than the new length of the vector (~S)." fill-pointer new-array-size)) fill-pointer) ((eq fill-pointer t) new-array-size) (t - (error "Bogus value for :fill-pointer in adjust-array: ~S" + (error "bogus value for :FILL-POINTER in ADJUST-ARRAY: ~S" fill-pointer)))) (defun shrink-vector (vector new-size) @@ -933,7 +934,7 @@ (make-array length :initial-element t))) (when initial-element-p (unless (typep initial-element element-type) - (error "~S cannot be used to initialize an array of type ~S." + (error "~S can't be used to initialize an array of type ~S." initial-element element-type)) (fill (the simple-vector *zap-array-data-temp*) initial-element :end length)) @@ -1019,7 +1020,7 @@ (t (unless (bit-array-same-dimensions-p bit-array-1 result-bit-array) - (error "~S and ~S do not have the same dimensions." + (error "~S and ~S don't have the same dimensions." bit-array-1 result-bit-array)) result-bit-array))) @@ -1035,7 +1036,7 @@ (declare (type (array bit) bit-array-1 bit-array-2) (type (or (array bit) (member t nil)) result-bit-array)) (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2) - (error "~S and ~S do not have the same dimensions." + (error "~S and ~S don't have the same dimensions." bit-array-1 bit-array-2)) (let ((result-bit-array (pick-result-array result-bit-array bit-array-1))) (if (and (simple-bit-vector-p bit-array-1) diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index f4eb5c0..d0e4395 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -183,6 +183,13 @@ (frob (simple-array (unsigned-byte 4) (*)) 4)) ;;;; simple string transforms +;;;; +;;;; Note: CMU CL had more of these, including transforms for +;;;; functions which cons. In SBCL, we've gotten rid 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. (deftransform subseq ((string start &optional (end nil)) (simple-string t &optional t)) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index f08add4..f474bc1 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -98,30 +98,32 @@ ;;;; external entry point creation -;;; Return a Lambda form that can be used as the definition of the XEP for Fun. -;;; -;;; If Fun is a lambda, then we check the number of arguments (conditional -;;; on policy) and call Fun with all the arguments. -;;; -;;; If Fun is an Optional-Dispatch, then we dispatch off of the number of -;;; supplied arguments by doing do an = test for each entry-point, calling the -;;; entry with the appropriate prefix of the passed arguments. -;;; -;;; If there is a more arg, then there are a couple of optimizations that we -;;; make (more for space than anything else): -;;; -- If Min-Args is 0, then we make the more entry a T clause, since no -;;; argument count error is possible. -;;; -- We can omit the = clause for the last entry-point, allowing the case of -;;; 0 more args to fall through to the more entry. -;;; -;;; We don't bother to policy conditionalize wrong arg errors in optional -;;; dispatches, since the additional overhead is negligible compared to the -;;; other hair going down. -;;; -;;; Note that if policy indicates it, argument type declarations in Fun will -;;; be verified. Since nothing is known about the type of the XEP arg vars, -;;; type checks will be emitted when the XEP's arg vars are passed to the -;;; actual function. +;;; Return a Lambda form that can be used as the definition of the XEP +;;; for FUN. +;;; +;;; If FUN is a lambda, then we check the number of arguments +;;; (conditional on policy) and call FUN with all the arguments. +;;; +;;; If FUN is an OPTIONAL-DISPATCH, then we dispatch off of the number +;;; of supplied arguments by doing do an = test for each entry-point, +;;; calling the entry with the appropriate prefix of the passed +;;; arguments. +;;; +;;; If there is a more arg, then there are a couple of optimizations +;;; that we make (more for space than anything else): +;;; -- If MIN-ARGS is 0, then we make the more entry a T clause, since +;;; no argument count error is possible. +;;; -- We can omit the = clause for the last entry-point, allowing the +;;; case of 0 more args to fall through to the more entry. +;;; +;;; We don't bother to policy conditionalize wrong arg errors in +;;; optional dispatches, since the additional overhead is negligible +;;; compared to the cost of everything else going on. +;;; +;;; Note that if policy indicates it, argument type declarations in +;;; Fun will be verified. Since nothing is known about the type of the +;;; XEP arg vars, type checks will be emitted when the XEP's arg vars +;;; are passed to the actual function. (defun make-xep-lambda (fun) (declare (type functional fun)) (etypecase fun @@ -148,9 +150,9 @@ (entries `((= ,n-supplied ,n) (%funcall ,(first eps) ,@(subseq temps 0 n))))) `(lambda (,n-supplied ,@temps) - ;; FIXME: Make sure that INDEX type distinguishes between target - ;; and host. (Probably just make the SB!XC:DEFTYPE different from - ;; CL:DEFTYPE.) + ;; FIXME: Make sure that INDEX type distinguishes between + ;; target and host. (Probably just make the SB!XC:DEFTYPE + ;; different from CL:DEFTYPE.) (declare (type index ,n-supplied)) (cond ,@(if more (butlast (entries)) (entries)) @@ -659,13 +661,14 @@ (link-blocks call-block bind-block) next-block))) -;;; Handle the environment semantics of LET conversion. We add the lambda -;;; and its LETs to lets for the Call's home function. We merge the calls for -;;; Fun with the calls for the home function, removing Fun in the process. We -;;; also merge the Entries. +;;; Handle the environment semantics of LET conversion. We add the +;;; lambda and its LETs to lets for the CALL's home function. We merge +;;; the calls for FUN with the calls for the home function, removing +;;; FUN in the process. We also merge the Entries. ;;; ;;; We also unlink the function head from the component head and set -;;; Component-Reanalyze to true to indicate that the DFO should be recomputed. +;;; COMPONENT-REANALYZE to true to indicate that the DFO should be +;;; recomputed. (defun merge-lets (fun call) (declare (type clambda fun) (type basic-combination call)) (let ((component (block-component (node-block call)))) @@ -693,8 +696,7 @@ (setf (lambda-lets fun) ())) (setf (lambda-calls home) - (nunion (lambda-calls fun) - (delete fun (lambda-calls home)))) + (delete fun (nunion (lambda-calls fun) (lambda-calls home)))) (setf (lambda-calls fun) ()) (setf (lambda-entries home) @@ -702,18 +704,19 @@ (setf (lambda-entries fun) ())) (values)) -;;; Handle the value semantics of let conversion. Delete Fun's return node, -;;; and change the control flow to transfer to Next-Block instead. Move all -;;; the uses of the result continuation to Call's Cont. +;;; Handle the value semantics of LET conversion. Delete FUN's return +;;; node, and change the control flow to transfer to NEXT-BLOCK +;;; instead. Move all the uses of the result continuation to CALL's +;;; CONT. ;;; -;;; If the actual continuation is only used by the let call, then we -;;; intersect the type assertion on the dummy continuation with the assertion -;;; for the actual continuation; in all other cases assertions on the dummy -;;; continuation are lost. +;;; If the actual continuation is only used by the LET call, then we +;;; intersect the type assertion on the dummy continuation with the +;;; assertion for the actual continuation; in all other cases +;;; assertions on the dummy continuation are lost. ;;; -;;; We also intersect the derived type of the call with the derived type of -;;; all the dummy continuation's uses. This serves mainly to propagate -;;; TRULY-THE through lets. +;;; We also intersect the derived type of the CALL with the derived +;;; type of all the dummy continuation's uses. This serves mainly to +;;; propagate TRULY-THE through LETs. (defun move-return-uses (fun call next-block) (declare (type clambda fun) (type basic-combination call) (type cblock next-block)) @@ -735,9 +738,9 @@ (substitute-continuation-uses cont result))) (values)) -;;; Change all Cont for all the calls to Fun to be the start continuation -;;; for the bind node. This allows the blocks to be joined if the caller count -;;; ever goes to one. +;;; Change all CONT for all the calls to FUN to be the start +;;; continuation for the bind node. This allows the blocks to be +;;; joined if the caller count ever goes to one. (defun move-let-call-cont (fun) (declare (type clambda fun)) (let ((new-cont (node-prev (lambda-bind fun)))) @@ -747,15 +750,16 @@ (add-continuation-use dest new-cont)))) (values)) -;;; We are converting Fun to be a let when the call is in a non-tail -;;; position. Any previously tail calls in Fun are no longer tail calls, and -;;; must be restored to normal calls which transfer to Next-Block (Fun's -;;; return point.) We can't do this by DO-USES on the RETURN-RESULT, because -;;; the return might have been deleted (if all calls were TR.) +;;; We are converting FUN to be a LET when the call is in a non-tail +;;; position. Any previously tail calls in FUN are no longer tail +;;; calls, and must be restored to normal calls which transfer to +;;; NEXT-BLOCK (FUN's return point.) We can't do this by DO-USES on +;;; the RETURN-RESULT, because the return might have been deleted (if +;;; all calls were TR.) ;;; -;;; The called function might be an assignment in the case where we are -;;; currently converting that function. In steady-state, assignments never -;;; appear in the lambda-calls. +;;; The called function might be an assignment in the case where we +;;; are currently converting that function. In steady-state, +;;; assignments never appear in the lambda-calls. (defun unconvert-tail-calls (fun call next-block) (dolist (called (lambda-calls fun)) (dolist (ref (leaf-refs called)) @@ -777,21 +781,23 @@ (assert (eq called fun)))))))) (values)) -;;; Deal with returning from a let or assignment that we are converting. -;;; FUN is the function we are calling, CALL is a call to FUN, and NEXT-BLOCK -;;; is the return point for a non-tail call, or NULL if call is a tail call. -;;; -;;; If the call is not a tail call, then we must do UNCONVERT-TAIL-CALLS, since -;;; a tail call is a call which returns its value out of the enclosing non-let -;;; function. When call is non-TR, we must convert it back to an ordinary -;;; local call, since the value must be delivered to the receiver of CALL's -;;; value. -;;; -;;; We do different things depending on whether the caller and callee have -;;; returns left: -;;; -- If the callee has no return we just do MOVE-LET-CALL-CONT. Either the -;;; function doesn't return, or all returns are via tail-recursive local -;;; calls. +;;; Deal with returning from a LET or assignment that we are +;;; converting. FUN is the function we are calling, CALL is a call to +;;; FUN, and NEXT-BLOCK is the return point for a non-tail call, or +;;; NULL if call is a tail call. +;;; +;;; If the call is not a tail call, then we must do +;;; UNCONVERT-TAIL-CALLS, since a tail call is a call which returns +;;; its value out of the enclosing non-let function. When call is +;;; non-TR, we must convert it back to an ordinary local call, since +;;; the value must be delivered to the receiver of CALL's value. +;;; +;;; We do different things depending on whether the caller and callee +;;; have returns left: + +;;; -- If the callee has no return we just do MOVE-LET-CALL-CONT. Either +;;; the function doesn't return, or all returns are via tail-recursive +;;; local calls. ;;; -- If CALL is a non-tail call, or if both have returns, then we ;;; delete the callee's return, move its uses to the call's result ;;; continuation, and transfer control to the appropriate return point. @@ -818,11 +824,11 @@ (values)) ;;; Actually do LET conversion. We call subfunctions to do most of the -;;; work. We change the CALL's cont to be the continuation heading the bind -;;; block, and also do REOPTIMIZE-CONTINUATION on the args and Cont so that -;;; let-specific IR1 optimizations get a chance. We blow away any entry for -;;; the function in *FREE-FUNCTIONS* so that nobody will create new reference -;;; to it. +;;; work. We change the CALL's cont to be the continuation heading the +;;; bind block, and also do REOPTIMIZE-CONTINUATION on the args and +;;; Cont so that let-specific IR1 optimizations get a chance. We blow +;;; away any entry for the function in *FREE-FUNCTIONS* so that nobody +;;; will create new reference to it. (defun let-convert (fun call) (declare (type clambda fun) (type basic-combination call)) (let ((next-block (if (node-tail-p call) @@ -840,10 +846,10 @@ (reoptimize-continuation (node-cont call)) (values)) -;;; We also don't convert calls to named functions which appear in the initial -;;; component, delaying this until optimization. This minimizes the likelyhood -;;; that we well let-convert a function which may have references added due to -;;; later local inline expansion +;;; We also don't convert calls to named functions which appear in the +;;; initial component, delaying this until optimization. This +;;; minimizes the likelyhood that we well let-convert a function which +;;; may have references added due to later local inline expansion (defun ok-initial-convert-p (fun) (not (and (leaf-name fun) (eq (component-kind @@ -852,23 +858,24 @@ :initial)))) ;;; This function is called when there is some reason to believe that -;;; the lambda Fun might be converted into a let. This is done after local -;;; call analysis, and also when a reference is deleted. We only convert to a -;;; let when the function is a normal local function, has no XEP, and is -;;; referenced in exactly one local call. Conversion is also inhibited if the -;;; only reference is in a block about to be deleted. We return true if we -;;; converted. -;;; -;;; These rules may seem unnecessarily restrictive, since there are some -;;; cases where we could do the return with a jump that don't satisfy these -;;; requirements. The reason for doing things this way is that it makes the -;;; concept of a let much more useful at the level of IR1 semantics. The -;;; :ASSIGNMENT function kind provides another way to optimize calls to -;;; single-return/multiple call functions. -;;; -;;; We don't attempt to convert calls to functions that have an XEP, since -;;; we might be embarrassed later when we want to convert a newly discovered -;;; local call. Also, see OK-INITIAL-CONVERT-P. +;;; the lambda Fun might be converted into a let. This is done after +;;; local call analysis, and also when a reference is deleted. We only +;;; convert to a let when the function is a normal local function, has +;;; no XEP, and is referenced in exactly one local call. Conversion is +;;; also inhibited if the only reference is in a block about to be +;;; deleted. We return true if we converted. +;;; +;;; These rules may seem unnecessarily restrictive, since there are +;;; some cases where we could do the return with a jump that don't +;;; satisfy these requirements. The reason for doing things this way +;;; is that it makes the concept of a LET much more useful at the +;;; level of IR1 semantics. The :ASSIGNMENT function kind provides +;;; another way to optimize calls to single-return/multiple call +;;; functions. +;;; +;;; We don't attempt to convert calls to functions that have an XEP, +;;; since we might be embarrassed later when we want to convert a +;;; newly discovered local call. Also, see OK-INITIAL-CONVERT-P. (defun maybe-let-convert (fun) (declare (type clambda fun)) (let ((refs (leaf-refs fun))) @@ -895,9 +902,10 @@ ;;;; tail local calls and assignments -;;; Return T if there are no cleanups between Block1 and Block2, or if they -;;; definitely won't generate any cleanup code. Currently we recognize lexical -;;; entry points that are only used locally (if at all). +;;; Return T if there are no cleanups between BLOCK1 and BLOCK2, or if +;;; they definitely won't generate any cleanup code. Currently we +;;; recognize lexical entry points that are only used locally (if at +;;; all). (defun only-harmless-cleanups (block1 block2) (declare (type cblock block1 block2)) (or (eq block1 block2) @@ -911,17 +919,17 @@ (return nil))) (t (return nil))))))) -;;; If a potentially TR local call really is TR, then convert it to jump -;;; directly to the called function. We also call MAYBE-CONVERT-TO-ASSIGNMENT. -;;; The first value is true if we tail-convert. The second is the value of -;;; M-C-T-A. We can switch the succesor (potentially deleting the RETURN node) -;;; unless: +;;; If a potentially TR local call really is TR, then convert it to +;;; jump directly to the called function. We also call +;;; MAYBE-CONVERT-TO-ASSIGNMENT. The first value is true if we +;;; tail-convert. The second is the value of M-C-T-A. We can switch +;;; the succesor (potentially deleting the RETURN node) unless: ;;; -- The call has already been converted. ;;; -- The call isn't TR (some implicit MV PROG1.) -;;; -- The call is in an XEP (thus we might decide to make it non-tail so that -;;; we can use known return inside the component.) -;;; -- There is a change in the cleanup between the call in the return, so we -;;; might need to introduce cleanup code. +;;; -- The call is in an XEP (thus we might decide to make it non-tail +;;; so that we can use known return inside the component.) +;;; -- There is a change in the cleanup between the call in the return, +;;; so we might need to introduce cleanup code. (defun maybe-convert-tail-local-call (call) (declare (type combination call)) (let ((return (continuation-dest (node-cont call)))) @@ -940,25 +948,26 @@ (link-blocks block (node-block (lambda-bind fun))) (values t (maybe-convert-to-assignment fun)))))) -;;; Called when we believe it might make sense to convert Fun to an -;;; assignment. All this function really does is determine when a function -;;; with more than one call can still be combined with the calling function's -;;; environment. We can convert when: +;;; This is called when we believe it might make sense to convert Fun +;;; to an assignment. All this function really does is determine when +;;; a function with more than one call can still be combined with the +;;; calling function's environment. We can convert when: ;;; -- The function is a normal, non-entry function, and -;;; -- Except for one call, all calls must be tail recursive calls in the -;;; called function (i.e. are self-recursive tail calls) +;;; -- Except for one call, all calls must be tail recursive calls +;;; in the called function (i.e. are self-recursive tail calls) ;;; -- OK-INITIAL-CONVERT-P is true. ;;; -;;; There may be one outside call, and it need not be tail-recursive. Since -;;; all tail local calls have already been converted to direct transfers, the -;;; only control semantics needed are to splice in the body at the non-tail -;;; call. If there is no non-tail call, then we need only merge the -;;; environments. Both cases are handled by LET-CONVERT. -;;; -;;; ### It would actually be possible to allow any number of outside calls as -;;; long as they all return to the same place (i.e. have the same conceptual -;;; continuation.) A special case of this would be when all of the outside -;;; calls are tail recursive. +;;; There may be one outside call, and it need not be tail-recursive. +;;; Since all tail local calls have already been converted to direct +;;; transfers, the only control semantics needed are to splice in the +;;; body at the non-tail call. If there is no non-tail call, then we +;;; need only merge the environments. Both cases are handled by +;;; LET-CONVERT. +;;; +;;; ### It would actually be possible to allow any number of outside +;;; calls as long as they all return to the same place (i.e. have the +;;; same conceptual continuation.) A special case of this would be +;;; when all of the outside calls are tail recursive. (defun maybe-convert-to-assignment (fun) (declare (type clambda fun)) (when (and (not (functional-kind fun)) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp new file mode 100644 index 0000000..9a01572 --- /dev/null +++ b/tests/compiler.pure.lisp @@ -0,0 +1,27 @@ +(cl:in-package :cl-user) + +;;; Exercise a compiler bug by (crashing the compiler). +;;; +;;; This test code is from Douglas Crosher's simplified TICKLE-BUG +;;; (2000-09-06 on cmucl-imp). +;;; +;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by +;;; Martin Atzmueller (2000-09-13 on sbcl-devel). +(funcall (compile nil + '(lambda () + (labels ((fun1 () + (fun2)) + (fun2 () + (when nil + (tagbody + tag + (fun2) + (go tag))) + (when nil + (tagbody + tag + (fun1) + (go tag))))) + + (fun1) + nil)))) diff --git a/tests/pcl.impure.lisp b/tests/pcl.impure.lisp index e6ce531..d76233a 100644 --- a/tests/pcl.impure.lisp +++ b/tests/pcl.impure.lisp @@ -30,3 +30,7 @@ (defun function-using-gf-defined-in-this-file (x y n) (unless (minusp n) (gf-defined-in-this-file x y))) + +;;;; success + +(sb-ext:quit :unix-status 104) diff --git a/tests/run-tests.sh b/tests/run-tests.sh index de63a75..9b75c37 100644 --- a/tests/run-tests.sh +++ b/tests/run-tests.sh @@ -12,31 +12,51 @@ tenfour () { echo ok else echo test failed: $? - return 1 + exit 1 fi } # *.pure.lisp files are ordinary Lisp code with no side effects, # and we can run them all in a single Lisp process. -(for f in *.pure.lisp; do echo \"$f\"; done) | $sbcl ; tenfour +echo //running '*.pure.lisp' tests +echo //i.e. *.pure.lisp +(for f in *.pure.lisp; do + echo "(progn" + if [ -f $f ]; then + echo " (progn (format t \"//running $f test~%\") (load \"$f\"))" + fi + echo " (sb-ext:quit :unix-status 104))" +done) | $sbcl ; tenfour # *.impure.lisp files are Lisp code with side effects (e.g. doing DEFSTRUCT # or DEFTYPE or DEFVAR). Each one needs to be run as a separate # invocation of Lisp. +echo //running '*.impure.lisp' tests for f in *.impure.lisp; do - echo $f | $sbcl ; tenfour + if [ -f $f ]; then + echo //running $f test + echo "(load \"$f\")" | $sbcl ; tenfour + fi done # *.test.sh files are scripts to test stuff, typically stuff which can't # so easily be tested within Lisp itself. A file foo.test.sh # may be associated with other files foo*, e.g. foo.lisp, foo-1.lisp, # or foo.pl. +echo //running '*.test.sh' tests for f in *.test.sh; do - sh $f ; tenfour + if [ -f $f ]; then + echo //running $f test + sh $f ; tenfour + fi done # *.assertoids files contain ASSERTOID statements to test things # interpreted and at various compilation levels. +echo //running '*.assertoids' tests for f in *.assertoids; do - echo "(load \"$f\")" | $sbcl --eval '(load "assertoid.lisp")' ; tenfour + if [ -f $f ]; then + echo //running $f test + echo "(load \"$f\")" | $sbcl --eval '(load "assertoid.lisp")' ; tenfour + fi done diff --git a/tests/vector.pure.lisp b/tests/vector.pure.lisp index ba40859..bbe03a9 100644 --- a/tests/vector.pure.lisp +++ b/tests/vector.pure.lisp @@ -1,12 +1,14 @@ -(in-package :cl-user) +(cl:in-package :cl-user) -(defun vector-tests () - (let ((simple-t (make-array 35)) - (simple-u32 (make-array 50 :element-type '(unsigned-byte 32))) - (simple-character (make-string 44)) - (complex-t (make-array 35 :fill-pointer 3)) - (complex-u32 (make-array 88 :element-type '(unsigned-byte 32))) - (complex-character (make-array 14 - :element-type 'character - :fill-pointer t))) - (assert (= (length simple-t) 35)))) +(funcall (lambda () + (let ((simple-t (make-array 35)) + (simple-u32 (make-array 50 + :element-type '(unsigned-byte 32))) + (simple-character (make-string 44)) + (complex-t (make-array 35 :fill-pointer 3)) + (complex-u32 (make-array 88 + :element-type '(unsigned-byte 32))) + (complex-character (make-array 14 + :element-type 'character + :fill-pointer t))) + (assert (= (length simple-t) 35))))) diff --git a/version.lisp-expr b/version.lisp-expr index 9d15931..c8fa080 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string a la "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.7.18" +"0.6.7.19" -- 1.7.10.4