* bug fix: DEFGENERIC now works even when there's a function of the
same name in an enclosing lexical environment. (thanks to Zach
Beane)
+ * fixed compiler failure, caused by instrumenting code during
+ IR1-optimization. (Debian bug report #273606 by Gabor Melis)
* fixed some bugs revealed by Paul Dietz' test suite:
** POSITION on displaced vectors with non-zero displacement
returns the right answer.
(defvar *constants*)
(declaim (type hash-table *constants*))
+;;; *ALLOW-INSTRUMENTING* controls whether we should allow the
+;;; insertion of instrumenting code (like a (CATCH ...)) around code
+;;; to allow the debugger RETURN and STEP commands to function (we
+;;; disallow it for internal stuff).
+(defvar *allow-instrumenting*)
+
;;; miscellaneous forward declarations
(defvar *code-segment*)
#!+sb-dyncount (defvar *collect-dynamic-statistics*)
`(locally (declare (optimize (insert-step-conditions 0)))
(step-variable ,form-string ,form))))
(list
- (let* ((*step-arguments-p* (policy *lexenv* (= insert-step-conditions 3)))
+ (let* ((*step-arguments-p* (and *allow-instrumenting*
+ (policy *lexenv* (= insert-step-conditions 3))))
(step-form `(step-form ,form-string
',(source-path-original-source *current-path*)
*compile-file-pathname*))
;; KLUDGE: packages we're not interested in stepping.
(mapcar #'find-package '(sb!c sb!int sb!impl sb!kernel sb!pcl)))))))
(let ((lexenv *lexenv*))
- (and (policy lexenv (>= insert-step-conditions 2))
+ (and *allow-instrumenting*
+ (policy lexenv (>= insert-step-conditions 2))
(cond ((consp form)
(let ((op (car form)))
(or (and (consp op) (eq 'lambda (car op)))
(step-symbol-p op)))))
((symbolp form)
(and *step-arguments-p*
+ *allow-instrumenting*
(policy lexenv (= insert-step-conditions 3))
(not (consp (lexenv-find form vars)))
(not (constantp form))
'(lambda named-lambda instance-lambda lambda-with-lexenv))
(ir1-convert-lambdalike
thing
- :debug-name (debug-namify "#'" thing)
- :allow-debug-catch-tag t))
+ :debug-name (debug-namify "#'" thing)))
((legal-fun-name-p thing)
(find-lexically-apparent-fun
thing "as the argument to FUNCTION"))
(ir1-convert-lambda d
:source-name n
:debug-name (debug-namify
- "FLET " n)
- :allow-debug-catch-tag t))
+ "FLET " n)))
names defs)))
(processing-decls (decls nil fvars next result)
(let ((*lexenv* (make-lexenv :funs (pairlis names fvars))))
(ir1-convert-lambda def
:source-name name
:debug-name (debug-namify
- "LABELS " name)
- :allow-debug-catch-tag t))
+ "LABELS " name)))
names defs))))
;; Modify all the references to the dummy function leaves so
;;; Note that environment analysis replaces references to escape
;;; functions with references to the corresponding NLX-INFO structure.
(def-ir1-translator %escape-fun ((tag) start next result)
- (let ((fun (ir1-convert-lambda
- `(lambda ()
- (return-from ,tag (%unknown-values)))
- :debug-name (debug-namify "escape function for " tag))))
+ (let ((fun (let ((*allow-instrumenting* nil))
+ (ir1-convert-lambda
+ `(lambda ()
+ (return-from ,tag (%unknown-values)))
+ :debug-name (debug-namify "escape function for " tag)))))
(setf (functional-kind fun) :escape)
(reference-leaf start next result fun)))
;; called semi-inlining? A more descriptive name would
;; be nice. -- WHN 2002-01-07
(frob ()
- (let ((res (ir1-convert-lambda-for-defun
- (defined-fun-inline-expansion leaf)
- leaf t
- #'ir1-convert-inline-lambda)))
+ (let ((res (let ((*allow-instrumenting* t))
+ (ir1-convert-lambda-for-defun
+ (defined-fun-inline-expansion leaf)
+ leaf t
+ #'ir1-convert-inline-lambda))))
(setf (defined-fun-functional leaf) res)
(change-ref-leaf ref res))))
(if ir1-converting-not-optimizing-p
(block-next (node-block call)))
(let ((new-fun (ir1-convert-inline-lambda
res
- :debug-name (debug-namify "LAMBDA-inlined "
- source-name
+ :debug-name (debug-namify "LAMBDA-inlined "
+ source-name
"<unknown function>")))
(ref (lvar-use (combination-fun call))))
(change-ref-leaf ref new-fun)
;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf.
(defun ir1-convert-lambda (form &key (source-name '.anonymous.)
- debug-name
- allow-debug-catch-tag)
+ debug-name)
(unless (consp form)
(compiler-error "A ~S was found when expecting a lambda expression:~% ~S"
"The lambda expression has a missing or non-list lambda list:~% ~S"
form))
- (let ((*allow-debug-catch-tag* (and *allow-debug-catch-tag* allow-debug-catch-tag)))
- (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
- (make-lambda-vars (cadr form))
- (multiple-value-bind (forms decls) (parse-body (cddr form))
- (binding* (((*lexenv* result-type)
- (process-decls decls (append aux-vars vars) nil))
- (forms (if (and *allow-debug-catch-tag*
- (policy *lexenv* (>= insert-debug-catch 2)))
- `((catch (locally (declare (optimize (insert-step-conditions 0)))
- (make-symbol "SB-DEBUG-CATCH-TAG"))
- ,@forms))
- forms))
- (forms (if (eq result-type *wild-type*)
- forms
- `((the ,result-type (progn ,@forms)))))
- (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
- (ir1-convert-hairy-lambda forms vars keyp
- allow-other-keys
- aux-vars aux-vals
- :source-name source-name
- :debug-name debug-name)
- (ir1-convert-lambda-body forms vars
- :aux-vars aux-vars
- :aux-vals aux-vals
- :source-name source-name
- :debug-name debug-name))))
- (setf (functional-inline-expansion res) form)
- (setf (functional-arg-documentation res) (cadr form))
- res)))))
+ (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
+ (make-lambda-vars (cadr form))
+ (multiple-value-bind (forms decls) (parse-body (cddr form))
+ (binding* (((*lexenv* result-type)
+ (process-decls decls (append aux-vars vars) nil))
+ (forms (if (and *allow-instrumenting*
+ (policy *lexenv* (>= insert-debug-catch 2)))
+ `((catch (locally (declare (optimize (insert-step-conditions 0)))
+ (make-symbol "SB-DEBUG-CATCH-TAG"))
+ ,@forms))
+ forms))
+ (forms (if (eq result-type *wild-type*)
+ forms
+ `((the ,result-type (progn ,@forms)))))
+ (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
+ (ir1-convert-hairy-lambda forms vars keyp
+ allow-other-keys
+ aux-vars aux-vals
+ :source-name source-name
+ :debug-name debug-name)
+ (ir1-convert-lambda-body forms vars
+ :aux-vars aux-vars
+ :aux-vals aux-vals
+ :source-name source-name
+ :debug-name debug-name))))
+ (setf (functional-inline-expansion res) form)
+ (setf (functional-arg-documentation res) (cadr form))
+ res))))
;;; helper for LAMBDA-like things, to massage them into a form
;;; suitable for IR1-CONVERT-LAMBDA.
;;; 2003-01-25
(defun ir1-convert-lambdalike (thing &rest args
&key (source-name '.anonymous.)
- debug-name allow-debug-catch-tag)
- (declare (ignorable source-name debug-name allow-debug-catch-tag))
+ debug-name)
+ (declare (ignorable source-name debug-name))
(ecase (car thing)
((lambda) (apply #'ir1-convert-lambda thing args))
((instance-lambda)
;;; reflect the state at the definition site.
(defun ir1-convert-inline-lambda (fun &key
(source-name '.anonymous.)
- debug-name
- allow-debug-catch-tag)
- (declare (ignore allow-debug-catch-tag))
+ debug-name)
(destructuring-bind (decls macros symbol-macros &rest body)
(if (eq (car fun) 'lambda-with-lexenv)
(cdr fun)
:policy (lexenv-policy *lexenv*))))
(ir1-convert-lambda `(lambda ,@body)
:source-name source-name
- :debug-name debug-name
- :allow-debug-catch-tag nil))))
+ :debug-name debug-name))))
;;; Get a DEFINED-FUN object for a function we are about to define. If
;;; the function has been forward referenced, then substitute for the
the efficiency of stable code.")
(defvar *fun-names-in-this-file* nil)
-
-;;; *ALLOW-DEBUG-CATCH-TAG* controls whether we should allow the
-;;; insertion a (CATCH ...) around code to allow the debugger RETURN
-;;; command to function.
-(defvar *allow-debug-catch-tag* t)
\f
;;;; namespace management utilities
(declare (list path))
(let* ((*current-path* path)
(component (make-empty-component))
- (*current-component* component))
+ (*current-component* component)
+ (*allow-instrumenting* t))
(setf (component-name component) "initial component")
(setf (component-kind component) :initial)
(let* ((forms (if for-value `(,form) `(,form nil)))
opname
:debug-name (debug-namify
"LAMBDA CAR "
- opname)
- :allow-debug-catch-tag t)))))))))
+ opname))))))))))
(values))
;; Generate a reference to a manifest constant, creating a new leaf
(dolist (block (block-pred old-block))
(change-block-successor block old-block new-block))
- (ir1-convert new-start ctran filtered-lvar
- `(locally (declare (optimize (insert-step-conditions 0))) ,form))
+ (ir1-convert new-start ctran filtered-lvar form)
;; KLUDGE: Comments at the head of this function in CMU CL
;; said that somewhere in here we
#!+sb-show *compiler-trace-output*
*last-source-context* *last-original-source*
*last-source-form* *last-format-string* *last-format-args*
- *last-message-count* *lexenv* *fun-names-in-this-file*))
+ *last-message-count* *lexenv* *fun-names-in-this-file*
+ *allow-instrumenting*))
;;; Whether call of a function which cannot be defined causes a full
;;; warning.
(setf (component-name component)
(debug-namify "~S initial component" name))
(setf (component-kind component) :initial)
- (let* ((locall-fun (ir1-convert-lambdalike
- definition
- :debug-name (debug-namify "top level local call "
- name)
- ;; KLUDGE: we do this so that we get to have
- ;; nice debug returnness in functions defined
- ;; from the REPL
- :allow-debug-catch-tag t))
+ (let* ((locall-fun (let ((*allow-instrumenting* t))
+ (ir1-convert-lambdalike
+ definition
+ :debug-name (debug-namify "top level local call "
+ name))))
(fun (ir1-convert-lambda (make-xep-lambda-expression locall-fun)
:source-name (or name '.anonymous.)
:debug-name (unless name
'(original-source-start 0 0)))
(when name
(legal-fun-name-or-type-error name))
- (let* ((*lexenv* (make-lexenv :policy *policy*
+ (let* (
+ (*lexenv* (make-lexenv :policy *policy*
:handled-conditions *handled-conditions*
:disabled-package-locks *disabled-package-locks*))
(fun (make-functional-from-toplevel-lambda lambda-expression
(*source-info* info)
(*toplevel-lambdas* ())
(*fun-names-in-this-file* ())
+ (*allow-instrumenting* nil)
(*compiler-error-bailout*
(lambda ()
(compiler-mumble "~2&; fatal error, aborting compilation~%")
(*source-info* (make-lisp-source-info form))
(*toplevel-lambdas* ())
(*block-compile* nil)
+ (*allow-instrumenting* nil)
(*compiler-error-bailout*
(lambda (&optional error)
(declare (ignore error))
(TAGBODY (THE INTEGER (CATCH 'CT4 (LOGORC1 C -15950))) 1)
B))))
+(compile nil
+ '(lambda (buffer i end)
+ (declare (optimize (debug 3)))
+ (loop (when (not (eql 0 end)) (return)))
+ (let ((s (make-string end)))
+ (setf (schar s i) (schar buffer i))
+ s)))
+
;;; check that constant string prefix and suffix don't cause the
;;; compiler to emit code deletion notes.
(handler-bind ((sb-ext:code-deletion-note #'error))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.15.5"
+"0.8.15.6"
projects / sbcl.git / commitdiff