This is the mail archive of the
cgen@sources.redhat.com
mailing list for the CGEN project.
commit: make backtraces work reliably
- From: Jim Blandy <jimb at redhat dot com>
- To: cgen at sources dot redhat dot com
- Date: 15 Feb 2005 03:59:16 -0500
- Subject: commit: make backtraces work reliably
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 <jimb@redhat.com>
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))
)