to optimize code which uses those definitions? Setting this true
gives non-ANSI, early-CMU-CL behavior. It can be useful for improving
the efficiency of stable code.")
+
+;;; *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
(push node-block (block-pred block))
(add-continuation-use node cont)
(unless (eq (continuation-asserted-type cont) *wild-type*)
- (let ((new (values-type-union (continuation-asserted-type cont)
- (or (lexenv-find cont type-restrictions)
- *wild-type*))))
- (when (type/= new (continuation-asserted-type cont))
- (setf (continuation-asserted-type cont) new)
+ (let* ((restriction (or (lexenv-find cont type-restrictions)
+ *wild-type*))
+ (wrestriction (or (lexenv-find cont weakend-type-restrictions)
+ *wild-type*))
+ (newatype (values-type-union (continuation-asserted-type cont)
+ restriction))
+ (newctype (values-type-union (continuation-type-to-check cont)
+ wrestriction)))
+ (when (or (type/= newatype (continuation-asserted-type cont))
+ (type/= newctype (continuation-type-to-check cont)))
+ (setf (continuation-asserted-type cont) newatype)
+ (setf (continuation-type-to-check cont) newctype)
(reoptimize-continuation cont))))))
\f
;;;; exported functions
opname
:debug-name (debug-namify
"LAMBDA CAR ~S"
- opname)))))))))
+ opname)
+ :allow-debug-catch-tag t))))))))
(values))
;; Generate a reference to a manifest constant, creating a new leaf
;; or the cross-compiler which encountered the problem?"
#+sb-xc-host "(in cross-compiler macroexpansion of ~S)"
form))))
- (handler-bind (;; When cross-compiling, we can get style warnings
- ;; about e.g. undefined functions. An unhandled
- ;; CL:STYLE-WARNING (as opposed to a
- ;; SB!C::COMPILER-NOTE) would cause FAILURE-P to be
- ;; set on the return from #'SB!XC:COMPILE-FILE, which
- ;; would falsely indicate an error sufficiently
- ;; serious that we should stop the build process. To
- ;; avoid this, we translate CL:STYLE-WARNING
- ;; conditions from the host Common Lisp into
- ;; cross-compiler SB!C::COMPILER-NOTE calls. (It
- ;; might be cleaner to just make Python use
- ;; CL:STYLE-WARNING internally, so that the
- ;; significance of any host Common Lisp
- ;; CL:STYLE-WARNINGs is understood automatically. But
- ;; for now I'm not motivated to do this. -- WHN
- ;; 19990412)
- (style-warning (lambda (c)
- (compiler-note "~@<~A~:@_~A~:@_~A~:>"
- (wherestring) hint c)
- (muffle-warning-or-die)))
- ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for
+ (handler-bind ((style-warning (lambda (c)
+ (compiler-style-warn
+ "~@<~A~:@_~A~@:_~A~:>"
+ (wherestring) hint c)
+ (muffle-warning-or-die)))
+ ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for
;; Debian Linux, anyway) raises a CL:WARNING
;; condition (not a CL:STYLE-WARNING) for undefined
;; symbols when converting interpreted functions,
;; and this code does so, by crudely suppressing all
;; warnings in cross-compilation macroexpansion. --
;; WHN 19990412
- #+cmu
+ #+(and cmu sb-xc-host)
(warning (lambda (c)
(compiler-note
"~@<~A~:@_~
(wherestring)
c)
(muffle-warning-or-die)))
+ #-(and cmu sb-xc-host)
+ (warning (lambda (c)
+ (compiler-warn "~@<~A~:@_~A~@:_~A~:>"
+ (wherestring) hint c)
+ (muffle-warning-or-die)))
(error (lambda (c)
(compiler-error "~@<~A~:@_~A~@:_~A~:>"
(wherestring) hint c))))
(let ((node (make-combination fun-cont)))
(setf (continuation-dest fun-cont) node)
(assert-continuation-type fun-cont
- (specifier-type '(or function symbol)))
+ (specifier-type '(or function symbol))
+ (lexenv-policy *lexenv*))
(setf (continuation-%externally-checkable-type fun-cont) nil)
(collect ((arg-conts))
(let ((this-start fun-cont))
(setq ,n-value ,n-value-temp))))))
(when (and (not allowp) (eq keyword :allow-other-keys))
(setq found-allow-p t)
- (setq clause (append clause `((setq ,n-allowp ,n-value-temp)))))
+ (setq clause
+ (append clause `((setq ,n-allowp ,n-value-temp)))))
(temps `(,n-value ,default))
(tests clause)))
res))
;;; Convert a LAMBDA form into a LAMBDA leaf or an OPTIONAL-DISPATCH leaf.
-(defun ir1-convert-lambda (form &key (source-name '.anonymous.) debug-name)
+(defun ir1-convert-lambda (form &key (source-name '.anonymous.)
+ debug-name
+ allow-debug-catch-tag)
(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))
- (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))
- (let* ((result-cont (make-continuation))
- (*lexenv* (process-decls decls
- (append aux-vars vars)
- nil result-cont))
- (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 result-cont
- :source-name source-name
- :debug-name debug-name)
- (ir1-convert-lambda-body forms vars
- :aux-vars aux-vars
- :aux-vals aux-vals
- :result result-cont
- :source-name source-name
- :debug-name debug-name))))
- (setf (functional-inline-expansion res) form)
- (setf (functional-arg-documentation res) (cadr form))
- res))))
+ (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))
+ (let* ((result-cont (make-continuation))
+ (*lexenv* (process-decls decls
+ (append aux-vars vars)
+ nil result-cont))
+ (forms (if (and *allow-debug-catch-tag*
+ (policy *lexenv* (> debug (max speed space))))
+ `((catch (make-symbol "SB-DEBUG-CATCH-TAG")
+ ,@forms))
+ 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 result-cont
+ :source-name source-name
+ :debug-name debug-name)
+ (ir1-convert-lambda-body forms vars
+ :aux-vars aux-vars
+ :aux-vals aux-vals
+ :result result-cont
+ :source-name source-name
+ :debug-name debug-name))))
+ (setf (functional-inline-expansion res) form)
+ (setf (functional-arg-documentation res) (cadr form))
+ res)))))
\f
;;;; defining global functions
projects / sbcl.git / blobdiff