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