This is the mail archive of the cgen@sources.redhat.com mailing list for the CGEN project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

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))
  )


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]