From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 4844 invoked by alias); 15 Feb 2005 09:01:00 -0000 Mailing-List: contact cgen-help@sources.redhat.com; run by ezmlm Precedence: bulk List-Subscribe: List-Archive: List-Post: List-Help: , Sender: cgen-owner@sources.redhat.com Received: (qmail 3946 invoked from network); 15 Feb 2005 09:00:01 -0000 Received: from unknown (HELO mx1.redhat.com) (66.187.233.31) by sourceware.org with SMTP; 15 Feb 2005 09:00:01 -0000 Received: from int-mx1.corp.redhat.com (int-mx1.corp.redhat.com [172.16.52.254]) by mx1.redhat.com (8.12.11/8.12.11) with ESMTP id j1F901SB020540 for ; Tue, 15 Feb 2005 04:00:01 -0500 Received: from zenia.home.redhat.com (sebastian-int.corp.redhat.com [172.16.52.221]) by int-mx1.corp.redhat.com (8.11.6/8.11.6) with ESMTP id j1F900O15009; Tue, 15 Feb 2005 04:00:00 -0500 To: cgen@sources.redhat.com Subject: commit: make backtraces work reliably From: Jim Blandy Date: Tue, 15 Feb 2005 09:01:00 -0000 Message-ID: User-Agent: Gnus/5.09 (Gnus v5.9.0) Emacs/21.3 MIME-Version: 1.0 Content-Type: text/plain; charset=us-ascii X-SW-Source: 2005-q1/txt/msg00029.txt.bz2 Guile's utterly bewildering refusal to give me a decent backtrace finally made me so mad I had to go for a walk to settle down. With the patch below, I now get backtraces reliably with -b --- and with source locations, too. 2005-02-15 Jim Blandy Make backtraces work more reliably. * guile.scm: Set up debugging parameters, and enable debugging and source positions while loading. (cgen-call-with-debugging, cgen-debugging-stack-start): New functions. * read.scm: Don't set debugging parameters here. (catch-with-backtrace): Function deleted. (-cgen): Simply note the presence or absence of the -b option. Pass the flag to cgen-call-with-debugging, so debugging is turned off here if the user didn't request it, for faster computation. (cgen): Call cgen-debugging-stack-start here, instead of catch-with-backtrace. * guile.scm (debug-write): New function. Index: cgen/guile.scm =================================================================== RCS file: /cvs/src/src/cgen/guile.scm,v retrieving revision 1.1 diff -c -p -r1.1 guile.scm *** cgen/guile.scm 7 Feb 2005 18:51:31 -0000 1.1 --- cgen/guile.scm 15 Feb 2005 08:34:08 -0000 *************** *** 57,59 **** --- 57,144 ---- (symbol-bound? #f 'list-reverse!)) (define reverse! list-reverse!) ) + + (define (debug-write . objs) + (map (lambda (o) + ((if (string? o) display write) o (current-error-port))) + objs) + (newline (current-error-port))) + + + + ;;; Enabling and disabling debugging features of the host Scheme. + + ;;; For the initial load proces, turn everything on. We'll disable it + ;;; before we start doing the heavy computation. + (if (memq 'debug-extensions *features*) + (begin + (debug-enable 'backtrace) + (debug-enable 'debug) + (debug-enable 'backwards) + (debug-set! depth 2000) + (debug-set! maxdepth 2000) + (debug-set! stack 100000) + (debug-set! frames 10))) + (read-enable 'positions) + + ;;; Call THUNK, with debugging enabled if FLAG is true, or disabled if + ;;; FLAG is false. + ;;; + ;;; (On systems other than Guile, this needn't actually do anything at + ;;; all, beyond calling THUNK, so long as your backtraces are still + ;;; helpful. In Guile, the debugging evaluator is slower, so we don't + ;;; want to use it unless the user asked for it.) + (define (cgen-call-with-debugging flag thunk) + (if (memq 'debug-extensions *features*) + ((if flag debug-enable debug-disable) 'debug)) + + ;; Now, actually start using the debugging evaluator. + ;; + ;; Guile has two separate evaluators, one that does the extra + ;; bookkeeping for backtraces, and one which doesn't, but runs + ;; faster. However, the evaluation process (in either evaluator) + ;; ordinarily never consults the variable that says which evaluator + ;; to use: whatever evaluator was running just keeps rolling along. + ;; There are certain primitives, like some of the eval variants, + ;; that do actually check. start-stack is one such primitive, but + ;; we don't want to shadow whatever other stack id is there, so we + ;; do all the real work in the ID argument, and do nothing in the + ;; EXP argument. What a kludge. + (start-stack (begin (thunk) #t) #f)) + + + ;;; Apply PROC to ARGS, marking that application as the bottom of the + ;;; stack for error backtraces. + ;;; + ;;; (On systems other than Guile, this doesn't really need to do + ;;; anything other than apply PROC to ARGS, as long as something + ;;; ensures that backtraces will work right.) + (define (cgen-debugging-stack-start proc args) + + ;; Naming this procedure, rather than using an anonymous lambda, + ;; allows us to pass less fragile cut info to save-stack. + (define (handler . args) + ;;(display args (current-error-port)) + ;;(newline (current-error-port)) + ;; display-error takes 6 arguments. + ;; If `quit' is called from elsewhere, it may not have 6 + ;; arguments. Not sure how best to handle this. + (if (= (length args) 5) + (begin + (apply display-error #f (current-error-port) (cdr args)) + ;; Grab a copy of the current stack, + (save-stack handler 0) + (backtrace))) + (quit 1)) + + ;; Apply proc to args, and if any uncaught exception is thrown, call + ;; handler WITHOUT UNWINDING THE STACK (that's the 'lazy' part). We + ;; need the stack left alone so we can produce a backtrace. + (lazy-catch #t + (lambda () + ;; I have no idea why the 'load-stack' stack mark is + ;; not still present on the stack; we're still loading + ;; cgen-APP.scm, aren't we? But stack-id returns #f + ;; in handler if we don't do a start-stack here. + (start-stack proc (apply proc args))) + handler)) Index: cgen/read.scm =================================================================== RCS file: /cvs/src/src/cgen/read.scm,v retrieving revision 1.10 diff -c -p -r1.10 read.scm *** cgen/read.scm 16 Dec 2004 21:23:13 -0000 1.10 --- cgen/read.scm 15 Feb 2005 08:34:08 -0000 *************** *** 87,106 **** ; If a routine to initialize compiled-in code is defined, run it. (if (defined? 'cgen-init-c) (cgen-init-c)) - ; Don't use the debugging evaluator unless asked for. - (if (not (defined? 'DEBUG-EVAL)) - (define DEBUG-EVAL #f)) - - (if (and (not DEBUG-EVAL) - (memq 'debug-extensions *features*)) - (begin - (debug-disable 'debug) - (read-disable 'positions) - )) - - ; Extend the default limits of the interpreter stack - (debug-set! stack 100000) - ; If this is set to #f, the file is always loaded. ; Don't override any current setting, e.g. from dev.scm. (if (not (defined? 'CHECK-LOADED?)) --- 87,92 ---- *************** Define a preprocessor-style macro. *** 913,936 **** (cons (cons opt #f) (cdr argv)))))) ) - ; Used to ensure backtraces are printed if an error occurs. - - (define (catch-with-backtrace thunk) - (lazy-catch #t thunk - (lambda args - ;(display args (current-error-port)) - ;(newline (current-error-port)) - ; display-error takes 6 arguments. - ; If `quit' is called from elsewhere, it may not have 6 - ; arguments. Not sure how best to handle this. - (if (= (length args) 5) - (begin - (apply display-error #f (current-error-port) (cdr args)) - (save-stack) - (backtrace))) - (quit 1))) - ) - ; Return (cadr args) or print a pretty error message if not possible. (define (option-arg args) --- 899,904 ---- *************** Define a preprocessor-style macro. *** 1088,1093 **** --- 1056,1062 ---- (keep-isa "all") ; default is all isas (flags "") (moreopts? #t) + (debugging #f) ; default is off, for speed (cep (current-error-port)) (str=? string=?) ) *************** Define a preprocessor-style macro. *** 1105,1119 **** (set! arch-file arg) ) ((str=? "-b" (car opt)) ! (if (memq 'debug-extensions *features*) ! (begin ! (debug-enable 'backtrace) ! (debug-enable 'debug) ! (debug-enable 'backwards) ! (debug-set! depth 2000) ! (debug-set! maxdepth 2000) ! (debug-set! frames 10) ! (read-enable 'positions))) ) ((str=? "-d" (car opt)) (let ((prompt (string-append "cgen-" app-name "> "))) --- 1074,1080 ---- (set! arch-file arg) ) ((str=? "-b" (car opt)) ! (set! debugging #t) ) ((str=? "-d" (car opt)) (let ((prompt (string-append "cgen-" app-name "> "))) *************** Define a preprocessor-style macro. *** 1167,1217 **** ; All arguments have been parsed. ! (if (not arch-file) ! (error "-a option missing, no architecture specified")) ! ! (if repl? ! (debug-repl nil)) ! (cpu-load arch-file ! keep-mach keep-isa flags ! app-init! app-finish! app-analyze!) ! ; Start another repl loop if -d. ! ; Awkward. Both places are useful, though this is more useful. ! (if repl? ! (debug-repl nil)) ! ! ; Done with processing the arguments. ! ; Application arguments are processed in two passes. ! ; This is because the app may have arguments that specify things ! ; that affect file generation (e.g. to specify another input file) ! ; and we don't want to require an ordering of the options. ! ! (for-each (lambda (opt-arg) ! (let ((opt (car opt-arg)) ! (arg (cdr opt-arg))) ! (if (cadr opt) ! ((opt-get-first-pass opt) arg) ! ((opt-get-first-pass opt))))) ! (reverse app-args)) ! ! (for-each (lambda (opt-arg) ! (let ((opt (car opt-arg)) ! (arg (cdr opt-arg))) ! (if (cadr opt) ! ((opt-get-second-pass opt) arg) ! ((opt-get-second-pass opt))))) ! (reverse app-args)) ) ) #f) ; end of lambda ) ; Main entry point called by application file generators. - ; Cover fn to -cgen that uses catch-with-backtrace. - ; ??? (debug-enable 'backtrace) might also work except I seem to remember - ; having problems with it. They may be fixed now. - (define cgen (lambda args ! (catch-with-backtrace (lambda () (apply -cgen args)))) ) --- 1128,1178 ---- ; All arguments have been parsed. ! (cgen-call-with-debugging ! debugging ! (lambda () ! ! (if (not arch-file) ! (error "-a option missing, no architecture specified")) ! ! (if repl? ! (debug-repl nil)) ! (cpu-load arch-file ! keep-mach keep-isa flags ! app-init! app-finish! app-analyze!) ! ! ;; Start another repl loop if -d. ! ;; Awkward. Both places are useful, though this is more useful. ! (if repl? ! (debug-repl nil)) ! ! ;; Done with processing the arguments. Application arguments ! ;; are processed in two passes. This is because the app may ! ;; have arguments that specify things that affect file ! ;; generation (e.g. to specify another input file) and we ! ;; don't want to require an ordering of the options. ! (for-each (lambda (opt-arg) ! (let ((opt (car opt-arg)) ! (arg (cdr opt-arg))) ! (if (cadr opt) ! ((opt-get-first-pass opt) arg) ! ((opt-get-first-pass opt))))) ! (reverse app-args)) ! ! (for-each (lambda (opt-arg) ! (let ((opt (car opt-arg)) ! (arg (cdr opt-arg))) ! (if (cadr opt) ! ((opt-get-second-pass opt) arg) ! ((opt-get-second-pass opt))))) ! (reverse app-args)))) ) ) #f) ; end of lambda ) ; Main entry point called by application file generators. (define cgen (lambda args ! (cgen-debugging-stack-start -cgen args)) )