Improved handling of DEBUG and SAFETY declarations

src/cmp/cmpcall.lsp

@@ -154,7 +154,7 @@
   (cond
     ;; Check whether it is a global function that we cannot call directly.
      ((and (or (null loc) (fun-global loc)) (not (inline-possible fname)))
-      (if (and *compile-to-linking-call* (< *debug* 1))
+      (if (and *compile-to-linking-call* (<= *debug* 1))
 	  (call-linking-loc fname narg args)
 	  (call-unknown-global-loc fname nil narg args)))
 
@@ -164,8 +164,7 @@
       loc)
 
      ;; Call to a function defined in the same file.
-     ((and (fun-p loc)
-	   (< *debug* 1))
+     ((and (fun-p loc) (<= *debug* 1))
       (call-loc fname loc narg args))
 
      ((and (null loc) (setf loc (find fname *global-funs* :test #'same-fname-p
@@ -189,7 +188,7 @@
       (call-exported-function-loc fname narg args fd minarg maxarg t))
 
      ;; Linking calls can only be made to symbols
-     ((and *compile-to-linking-call* (< *debug* 1))
+     ((and *compile-to-linking-call* (<= *debug* 1))
       (call-linking-loc fname narg args))
 
      (t (call-unknown-global-loc fname loc narg args))))

src/cmp/cmpdefs.lsp

@@ -171,6 +171,7 @@
   (referred-funs nil)	;;; List of external functions called in this one.
 			;;; We only register direct calls, not calls via object.
   (child-funs nil)	;;; List of local functions defined here.
+  (debug 0)		;;; Debug quality
   )
 
 (defstruct (blk (:include ref))

src/cmp/cmpenv.lsp

@@ -346,6 +346,23 @@
   (values body ss ts is others doc all-declarations)
   )
 
+(defun default-optimization (optimization)
+  (ecase optimization
+    (speed *speed*)
+    (safety *safety*)
+    (space *space*)
+    (debug *debug*)))
+
+(defun search-optimization-quality (declarations what)
+  (dolist (i (reverse declarations)
+	   (default-optimization what))
+    (when (and (consp i) (eq (first i) 'optimize))
+      (dolist (j (rest i))
+	(cond ((consp j)
+	       (when (eq (first j) what) (return (second j))))
+	      ((eq j what)
+	       (return 3)))))))
+
 (defun c1add-declarations (decls &aux (dl nil))
   (dolist (decl decls dl)
     (case (car decl)

src/cmp/cmpexit.lsp

@@ -14,7 +14,7 @@
 
 (in-package "COMPILER")
 
-(defun unwind-bds (bds-lcl bds-bind stack-sp)
+(defun unwind-bds (bds-lcl bds-bind stack-sp ihs-p)
   (declare (fixnum bds-bind))
   (when stack-sp
     (wt-nl "cl_stack_set_index(" stack-sp ");"))
@@ -22,9 +22,11 @@
     (wt-nl "bds_unwind(" bds-lcl ");"))
   (if (< bds-bind 4)
       (dotimes (n bds-bind) (declare (fixnum n)) (wt-nl "bds_unwind1();"))
-      (wt-nl "bds_unwind_n(" bds-bind ");")))
+      (wt-nl "bds_unwind_n(" bds-bind ");"))
+  (when ihs-p
+    (wt-nl "ihs_pop();")))
 
-(defun unwind-exit (loc &optional (jump-p nil) &aux (bds-lcl nil) (bds-bind 0) (stack-sp nil))
+(defun unwind-exit (loc &optional (jump-p nil) &aux (bds-lcl nil) (bds-bind 0) (stack-sp nil) (ihs-p nil))
   (declare (fixnum bds-bind))
   (when (consp *destination*)
     (case (car *destination*)
@@ -47,7 +49,7 @@
 	      (cond ((and (consp *destination*)
 			  (or (eq (car *destination*) 'JUMP-TRUE)
 			      (eq (car *destination*) 'JUMP-FALSE)))
-		     (unwind-bds bds-lcl bds-bind stack-sp))
+		     (unwind-bds bds-lcl bds-bind stack-sp ihs-p))
 		    ((not (or bds-lcl (plusp bds-bind) stack-sp))
 		     (set-loc loc))
 		    ;; Save the value if LOC may possibly refer
@@ -58,33 +60,34 @@
 			    (temp (make-temp-var)))
 		       (let ((*destination* temp))
 			 (set-loc loc)) ; temp <- loc
-		       (unwind-bds bds-lcl bds-bind stack-sp)
+		       (unwind-bds bds-lcl bds-bind stack-sp ihs-p)
 		       (set-loc temp))) ; *destination* <- temp
 		    (t
 		     (set-loc loc)
-		     (unwind-bds bds-lcl bds-bind stack-sp)))
+		     (unwind-bds bds-lcl bds-bind stack-sp ihs-p)))
 	      (when jump-p (wt-nl) (wt-go *exit*))
 	      (return))
 	     (t (setq jump-p t))))
       ((numberp ue) (baboon)
        (setq bds-lcl ue bds-bind 0))
       (t (case ue
+	   (IHS (setf ihs-p t))
 	   (BDS-BIND (incf bds-bind))
 	   (RETURN
 	     (unless (eq *exit* 'RETURN) (baboon))
 	     ;; *destination* must be either RETURN or TRASH.
 	     (cond ((eq loc 'VALUES)
 		    ;; from multiple-value-prog1 or values
-		    (unwind-bds bds-lcl bds-bind stack-sp)
+		    (unwind-bds bds-lcl bds-bind stack-sp ihs-p)
 		    (wt-nl "return VALUES(0);"))
 		   ((eq loc 'RETURN)
 		    ;; from multiple-value-prog1 or values
-		    (unwind-bds bds-lcl bds-bind stack-sp)
+		    (unwind-bds bds-lcl bds-bind stack-sp ihs-p)
 		    (wt-nl "return value0;"))      
 		   (t
 		    (let* ((*destination* 'RETURN))
 		      (set-loc loc))
-		    (unwind-bds bds-lcl bds-bind stack-sp)
+		    (unwind-bds bds-lcl bds-bind stack-sp ihs-p)
 		    (wt-nl "return value0;")))
 	     (return))
 	   ((RETURN-FIXNUM RETURN-CHARACTER RETURN-DOUBLE-FLOAT
@@ -102,7 +105,7 @@
 	      (if (or bds-lcl (plusp bds-bind))
 		  (let ((lcl (make-lcl-var :type (second loc))))
 		    (wt-nl "{cl_fixnum " lcl "= " loc ";")
-		    (unwind-bds bds-lcl bds-bind stack-sp)
+		    (unwind-bds bds-lcl bds-bind stack-sp ihs-p)
 		    (wt-nl "return(" lcl ");}"))
 		  (progn
 		    (wt-nl "return(" loc ");")))
@@ -118,13 +121,13 @@
   ;;; Never reached
   )
 
-(defun unwind-no-exit (exit &aux (bds-lcl nil) (bds-bind 0) (stack-sp nil))
+(defun unwind-no-exit (exit &aux (bds-lcl nil) (bds-bind 0) (stack-sp nil) (ihs-p nil))
   (declare (fixnum bds-bind))
   (dolist (ue *unwind-exit* (baboon))
     (cond
        ((consp ue)
 	(cond ((eq ue exit)
-	       (unwind-bds bds-lcl bds-bind stack-sp)
+	       (unwind-bds bds-lcl bds-bind stack-sp ihs-p)
 	       (return))
 	      ((eq (first ue) 'STACK)
 	       (setf stack-sp (second ue)))))
@@ -133,7 +136,7 @@
        ((member ue '(RETURN RETURN-OBJECT RETURN-FIXNUM RETURN-CHARACTER
                             RETURN-DOUBLE-FLOAT RETURN-SINGLE-FLOAT))
         (if (eq exit ue)
-          (progn (unwind-bds bds-lcl bds-bind stack-sp)
+          (progn (unwind-bds bds-lcl bds-bind stack-sp ihs-p)
                  (return))
           (baboon))
         ;;; Never reached
@@ -141,7 +144,7 @@
        ((eq ue 'FRAME) (wt-nl "frs_pop();"))
        ((eq ue 'TAIL-RECURSION-MARK)
         (if (eq exit 'TAIL-RECURSION-MARK)
-          (progn (unwind-bds bds-lcl bds-bind stack-sp)
+          (progn (unwind-bds bds-lcl bds-bind stack-sp ihs-p)
                  (return))
           (baboon))
         ;;; Never reached

src/cmp/cmplam.lsp

@@ -89,8 +89,12 @@ The function thus belongs to the type of functions that cl_make_cfun accepts."
 				     (si::function-block-name name)))
 	 (children (fun-child-funs fun))
 	 (global (and (assoc 'SI::C-GLOBAL decl) 'T))
-	 (no-entry (and (plusp *debug*) (assoc 'SI::C-LOCAL decl) 'T))
+	 (debug (search-optimization-quality decl 'debug))
+	 (no-entry (assoc 'SI::C-LOCAL decl))
 	 cfun exported minarg maxarg)
+    (when (and no-entry (>= debug 2))
+      (setf no-entry nil)
+      (cmpnote "Ignoring SI::C-LOCAL declaration for ~A when DEBUG is ~D" name debug))
     (unless (eql setjmps *setjmps*)
       (setf (c1form-volatile lambda-expr) t))
     (setf (fun-lambda fun) lambda-expr)
@@ -117,7 +121,8 @@ The function thus belongs to the type of functions that cl_make_cfun accepts."
 	  (fun-minarg fun) minarg
 	  (fun-maxarg fun) maxarg
 	  (fun-description fun) name
-	  (fun-no-entry fun) no-entry)
+	  (fun-no-entry fun) no-entry
+	  (fun-debug fun) debug)
     (reduce #'add-referred-variables-to-function
 	    (mapcar #'fun-referred-vars children)
 	    :initial-value fun)
@@ -280,7 +285,6 @@ The function thus belongs to the type of functions that cl_make_cfun accepts."
 		 (*permanent-data* t)
 		 (*unwind-exit* *unwind-exit*)
 		 (*env* *env*)
-		 (block-p nil)
 		 (last-arg))
   (declare (fixnum nreq nkey))
 
@@ -302,7 +306,7 @@ The function thus belongs to the type of functions that cl_make_cfun accepts."
 
   ;; check arguments
   (unless (or local-entry-p (not (compiler-check-args)))
-    (setq block-p t)
+    (incf *inline-blocks*)
     (if (and use-narg (not varargs))
 	(wt-nl "if(narg!=" nreq ") FEwrong_num_arguments_anonym();")
 	(when varargs
@@ -461,7 +465,7 @@ The function thus belongs to the type of functions that cl_make_cfun accepts."
   ;;; Now the parameters are ready, after all!
   (c2expr body)
 
-  (when block-p (wt-nl "}"))
+  ;;; Closing braces is done i cmptop.lsp
   )
 
 (defun optimize-funcall/apply-lambda (lambda-form arguments apply-p

src/cmp/cmpmain.lsp

@@ -852,8 +852,8 @@ Cannot compile ~a."
    ))
 
 (defun print-compiler-info ()
-  (format t "~&;;; OPTIMIZE levels: Safety=~d, Space=~d, Speed=~d~%"
-	  *safety* *space* *speed*))
+  (format t "~&;;; OPTIMIZE levels: Safety=~d, Space=~d, Speed=~d, Debug=~d~%"
+	  *safety* *space* *speed* *debug*))
 
 (defmacro with-compilation-unit (options &rest body)
   `(progn ,@body))

src/cmp/cmptop.lsp

@@ -117,8 +117,7 @@
 	 (c-output-file *compiler-output1*)
 	 (*compiler-output1* (make-string-output-stream))
 	 (*emitted-local-funs* nil)
-	 (*compiler-declared-globals* (make-hash-table))
-	 #+PDE (optimize-space (>= *space* 3)))
+	 (*compiler-declared-globals* (make-hash-table)))
     (unless shared-data
       (wt-nl1 "#include \"" (si::coerce-to-filename data-pathname) "\""))
     (wt-nl1 "#ifdef __cplusplus")
@@ -569,6 +568,8 @@
 	" VLEX" *reservation-cmacro*
 	" CLSR" *reservation-cmacro*)
     (wt-nl *volatile* "cl_object value0;")
+    (when (>= (fun-debug fun) 2)
+      (wt-nl "struct ihs_frame ihs;"))
     (when (eq (fun-closure fun) 'CLOSURE)
       (let ((clv-used (remove-if
 		       #'(lambda (x)
@@ -602,6 +603,12 @@
               (pop clv-used)))
 	  (wt-nl "{ /* ... closure scanning finished */")
 	  (incf *inline-blocks*)))
+    ;; If we ask for high level of debugging information, we push the function
+    ;; name into the invocation stack
+    (when (>= (fun-debug fun) 2)
+      (push 'IHS *unwind-exit*)
+      (wt-nl "ihs_push(&ihs," (add-symbol (fun-name fun)) ");"))
+
     (c2lambda-expr (c1form-arg 0 lambda-expr)
 		   (c1form-arg 2 lambda-expr)
 		   (fun-cfun fun) (fun-name fun)