New declaration C::POLICY-DEBUG-IHS-FRAME

src/clos/conditions.lsp

@@ -741,7 +741,8 @@ that caused the error.  CONTINUE-FORMAT-STRING and ERROR-FORMAT-STRING are the
 format strings of the error message.  ARGS are the arguments to the format
 strings."
   (declare (inline apply) ;; So as not to get bogus frames in debugger
-	   (ignore error-name))
+	   (ignore error-name)
+           (c::policy-debug-ihs-frame))
   (let ((condition (coerce-to-condition datum args 'simple-error 'error)))
     (cond
       ((eq t continue-string)

src/cmp/cmpenv.lsp

@@ -362,7 +362,8 @@
 	      (:READ-ONLY
 	       (push decl others))
 	      ((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL SI::C-GLOBAL
-		DYNAMIC-EXTENT IGNORABLE VALUES SI::NO-CHECK-TYPE)
+		DYNAMIC-EXTENT IGNORABLE VALUES SI::NO-CHECK-TYPE
+                POLICY-DEBUG-IHS-FRAME)
 	       (push decl others))
 	      (otherwise
 	       (if (member decl-name si::*alien-declarations*)
@@ -388,6 +389,9 @@
 (defun search-optimization-quality (declarations what)
   (dolist (i (reverse declarations)
 	   (default-optimization what))
+    (when (and (consp i) (eq (first i) 'policy-debug-ihs-frame)
+               (eq what 'debug))
+      (return 2))      
     (when (and (consp i) (eq (first i) 'optimize))
       (dolist (j (rest i))
 	(cond ((consp j)
@@ -418,6 +422,10 @@
 	       (SPEED (setf (fourth optimizations) value))
 	       (COMPILATION-SPEED)
 	       (t (cmpwarn "The OPTIMIZE quality ~s is unknown." (car x))))))))
+      (POLICY-DEBUG-IHS-FRAME
+       (unless optimizations
+         (setq optimizations (cmp-env-all-optimizations)))
+       (setf (first optimizations) (max 2 (first optimizations))))
       (FTYPE
        (if (atom (rest decl))
 	   (cmpwarn "Syntax error in declaration ~a" decl)
@@ -664,3 +672,9 @@
 (defun policy-array-bounds-check-p (&optional (env *cmp-env*))
   "Check access to array bounds?"
   (>= (cmp-env-optimization 'safety env) 1))
+
+(defun policy-debug-ihs-frame (&optional (env *cmp-env*))
+  "Shall we create an IHS frame so that this function shows up in backtraces?"
+  ;; Note that this is a prerequisite for registering variable bindings. Hence,
+  ;; it has to be recorded in a special variable.
+  (>= (fun-debug *current-function*) 2))

src/lsp/assert.lsp

@@ -17,6 +17,7 @@
   (list (eval (read *query-io*))))
 
 (defun wrong-type-argument (object type &optional place function)
+  (declare (c::policy-debug-ihs-frame))
   (tagbody again
      (restart-case
 	 (error 'simple-type-error

src/lsp/top.lsp

@@ -552,6 +552,7 @@ Use special code 0 to cancel this operation.")
 		 ((:prompt-hook *tpl-prompt-hook*) *tpl-prompt-hook*)
   		 (broken-at nil)
 		 (quiet nil))
+  (declare (c::policy-debug-ihs-frame))
   (let* ((*ihs-base* *ihs-top*)
 	 (*ihs-top* (if broken-at (ihs-search t broken-at) (ihs-top)))
 	 (*ihs-current* (if broken-at (ihs-prev *ihs-top*) *ihs-top*))
@@ -938,16 +939,18 @@ Use special code 0 to cancel this operation.")
 	     )))
     (let ((top (ihs-top)))
       (unless (> ihs-index top)
-        (loop with bds-min = (ihs-bds ihs-index)
+        (loop with bds-min = (1+ (ihs-bds ihs-index))
            with bds-max = (if (= ihs-index top)
                               (bds-top)
                               (ihs-bds (1+ ihs-index)))
-           for i from bds-min below bds-max
+           for i from bds-min to bds-max
            for variable = (bds-var i)
            for value = (bds-val i)
            unless (assoc variable special-variables)
            do (setf special-variables (acons variable value special-variables)))))
-    (values local-variables special-variables functions blocks)))
+    (values (nreverse local-variables)
+            (nreverse special-variables)
+            functions blocks)))
 
 (defun tpl-print-variables (prefix variables no-values)
   ;; This format is what was in the orignal code.
@@ -1407,6 +1410,7 @@ package."
   ;; call *INVOKE-DEBUGGER-HOOK* first, so that *DEBUGGER-HOOK* is not
   ;; called when the debugger is disabled. We adopt this mechanism
   ;; from SBCL.
+  (declare (c::policy-debug-ihs-frame))
   (let ((old-hook *invoke-debugger-hook*))
     (when old-hook
       (let ((*invoke-debugger-hook* nil))

src/new-cmp/cmpenv.lsp

@@ -295,7 +295,8 @@
 	      (:READ-ONLY
 	       (push decl others))
 	      ((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL SI::C-GLOBAL
-		DYNAMIC-EXTENT IGNORABLE VALUES SI::NO-CHECK-TYPE)
+		DYNAMIC-EXTENT IGNORABLE VALUES SI::NO-CHECK-TYPE
+                POLICY-DEBUG-IHS-FRAME)
 	       (push decl others))
 	      (otherwise
 	       (multiple-value-bind (ok type)
@@ -317,6 +318,9 @@
 (defun search-optimization-quality (declarations what)
   (dolist (i (reverse declarations)
 	   (default-optimization what))
+    (when (and (consp i) (eq (first i) 'policy-debug-ihs-frame)
+               (eq what 'debug))
+      (return 2))      
     (when (and (consp i) (eq (first i) 'optimize))
       (dolist (j (rest i))
 	(cond ((consp j)
@@ -352,6 +356,8 @@
       (OPTIMIZE
        (let ((optimizations (compute-optimizations (rest decl) env)))
          (setf env (cmp-env-add-declaration 'optimize optimizations))))
+      (POLICY-DEBUG-IHS-FRAME
+       (setf env (cmp-env-add-declaration 'optimize (compute-optimizations '(debug 2) env))))
       (FTYPE
        (if (atom (rest decl))
 	   (cmpwarn "Syntax error in declaration ~a" decl)