common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

0.6.7.19: added stop-compiler-crash patch from Martin Atzmueller

Browse source
This commit is contained in:
William Harold Newman 2000-10-20 18:05:09 +00:00
parent 49dfecae13
commit 06cb0db045
9 changed files with 248 additions and 175 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
NEWS
View file

@ -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 <a bug in ??>.)
?? 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.

83
src/code/array.lisp
View file

@ -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)

7
src/compiler/generic/vm-tran.lisp
View file

@ -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))

237
src/compiler/locall.lisp
View file

@ -98,30 +98,32 @@
;;;; external entry point creation
;;; Return a Lambda form that can be used as the definition of the XEP for Fun.
;;; 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 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 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.
;;; 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.
;;; 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.
;;; 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.
;;; 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.
;;; 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.
;;; 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.
;;; 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.
;;; 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.
;;; 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.
;;; 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.
;;; ### 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))

27
tests/compiler.pure.lisp Normal file
View file

@ -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))))

4
tests/pcl.impure.lisp
View file

@ -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)

30
tests/run-tests.sh
View file

@ -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

24
tests/vector.pure.lisp
View file

@ -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)))))

2
version.lisp-expr
View file

@ -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"