0.7.11.10:

[sbcl.git] / src / compiler / ir1tran.lisp

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 5343ea7..e6f917f 100644 (file)
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -48,6 +48,11 @@
   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
 
@@ -330,11 +335,18 @@
     (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
@@ -494,7 +506,8 @@
                                               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
@@ -747,7 +760,8 @@
   (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))
@@ -1652,7 +1666,8 @@
                                       (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)))
@@ -1932,7 +1947,9 @@
     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"
@@ -1948,28 +1965,34 @@
      "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