From e7317997dfb82dfe28245259b9d366b55eb6643c Mon Sep 17 00:00:00 2001 From: jgarcia Date: Fri, 8 Feb 2008 21:49:47 +0000 Subject: [PATCH] Improved handling of DEBUG and SAFETY declarations --- src/cmp/cmpcall.lsp | 7 +++---- src/cmp/cmpdefs.lsp | 1 + src/cmp/cmpenv.lsp | 17 +++++++++++++++++ src/cmp/cmpexit.lsp | 31 +++++++++++++++++-------------- src/cmp/cmplam.lsp | 14 +++++++++----- src/cmp/cmpmain.lsp | 4 ++-- src/cmp/cmptop.lsp | 11 +++++++++-- 7 files changed, 58 insertions(+), 27 deletions(-) diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index 4f59133d9..3e8807fd2 100644 --- a/src/cmp/cmpcall.lsp +++ b/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)))) diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index bf23fdc21..123aca309 100644 --- a/src/cmp/cmpdefs.lsp +++ b/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)) diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp index ba252a0f8..0483a105e 100644 --- a/src/cmp/cmpenv.lsp +++ b/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) diff --git a/src/cmp/cmpexit.lsp b/src/cmp/cmpexit.lsp index f9acd5dbc..aca16582e 100644 --- a/src/cmp/cmpexit.lsp +++ b/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 diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index 02cd7eaa0..a28415a76 100644 --- a/src/cmp/cmplam.lsp +++ b/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 diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index 0e15192e7..fb9d082b5 100644 --- a/src/cmp/cmpmain.lsp +++ b/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)) diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index a2f7800f7..72974f0bd 100644 --- a/src/cmp/cmptop.lsp +++ b/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)