+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.
+
+ * Makefile.am (GUILE): Explicitly load guile.scm here, and leave a
+ trailing -s.
+ (desc, html, opcodes, sim-arch, sim-cpu, gas-test, sim-test):
+ Don't write out the trailing -s here.
+ * Makefile.in: Regenerated.
+ * cgen-doc.scm, cgen-gas.scm, cgen-stest.scm): Don't load
+ fixup.scm here; let the caller decide which Scheme's customization
+ file to preload.
+ * dev.scm: Load guile.scm, not fixup.scm.
+ * fixup.scm: Deleted; contents have all moved to guile.scm.
+ * README: Doc fix.
+
+ * guile.scm (debug-write): New function.
+
2005-02-14 Jim Blandy <jimb@redhat.com>
* pmacros.scm (pmacros-init!): For .eval macros, use eval1 as the
SUBDIRS = doc
-GUILE = `if test -f ../guile/libguile/guile ; then echo ../guile/libguile/guile; else echo guile ; fi`
+GUILE = "`if test -f ../guile/libguile/guile ; then echo ../guile/libguile/guile; else echo guile ; fi` -l guile -s"
CGENFLAGS = -v
ARCH = @arch@
ARCHFILE = $(srcroot)/../cpu/$(ARCH).cpu
# FIXME: needs more dependencies
desc: desc.scm
rm -f tmp-desc.h tmp-desc.c tmp-opinst.c
- $(GUILE) -s $(srcdir)/cgen-opc.scm \
+ $(GUILE) $(srcdir)/cgen-opc.scm \
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS)" \
.PHONY: html
html: desc.scm html.scm cgen-doc.scm
rm -f tmp-doc.html
- $(GUILE) -s $(srcdir)/cgen-doc.scm \
+ $(GUILE) $(srcdir)/cgen-doc.scm \
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS)" \
opcodes: opcodes.scm
rm -f tmp-opc.h tmp-itab.c
rm -f tmp-asm.in tmp-dis.in tmp-ibld.h tmp-ibld.in
- $(GUILE) -s $(srcdir)/cgen-opc.scm \
+ $(GUILE) $(srcdir)/cgen-opc.scm \
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS) opinst" \
# FIXME: needs more dependencies
sim-arch: sim.scm
rm -f tmp-arch.h tmp-arch.c tmp-cpuall.h
- $(GUILE) -s $(srcdir)/cgen-sim.scm \
+ $(GUILE) $(srcdir)/cgen-sim.scm \
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS)" \
sim-cpu: sim.scm
rm -f tmp-cpu.h tmp-cpu.c tmp-decode.h tmp-decode.c
rm -f tmp-model.c tmp-sem.c tmp-sem-switch.c
- $(GUILE) -s $(srcdir)/cgen-sim.scm \
+ $(GUILE) $(srcdir)/cgen-sim.scm \
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS)" \
echo "ISAS not specified!" ;\
exit 1 ;\
fi
- $(GUILE) -s $(srcdir)/cgen-gas.scm \
+ $(GUILE) $(srcdir)/cgen-gas.scm \
-s $(srcdir) \
$(CGENFLAGS) \
-a $(ARCHFILE) \
echo "ISAS not specified!" ;\
exit 1 ;\
fi
- $(GUILE) -s $(srcdir)/cgen-stest.scm \
+ $(GUILE) $(srcdir)/cgen-stest.scm \
-s $(srcdir) \
$(CGENFLAGS) \
-a $(ARCHFILE) \
-# Makefile.in generated automatically by automake 1.4 from Makefile.am
+# Makefile.in generated automatically by automake 1.4-p6 from Makefile.am
-# Copyright (C) 1994, 1995-8, 1999 Free Software Foundation, Inc.
+# Copyright (C) 1994, 1995-8, 1999, 2001 Free Software Foundation, Inc.
# This Makefile.in is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
# with or without modifications, as long as this notice is preserved.
SUBDIRS = doc
-GUILE = `if test -f ../guile/libguile/guile ; then echo ../guile/libguile/guile; else echo guile ; fi`
+GUILE = "`if test -f ../guile/libguile/guile ; then echo ../guile/libguile/guile; else echo guile ; fi` -l guile -s"
CGENFLAGS = -v
ARCH = @arch@
ARCHFILE = $(srcroot)/../cpu/$(ARCH).cpu
DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) $(TEXINFOS) $(EXTRA_DIST)
-TAR = tar
+TAR = gtar
GZIP_ENV = --best
all: all-redirect
.SUFFIXES:
all-recursive install-data-recursive install-exec-recursive \
installdirs-recursive install-recursive uninstall-recursive install-info-recursive \
check-recursive installcheck-recursive info-recursive dvi-recursive:
- @set fnord $(MAKEFLAGS); amf=$$2; \
+ @set fnord $$MAKEFLAGS; amf=$$2; \
dot_seen=no; \
target=`echo $@ | sed s/-recursive//`; \
list='$(SUBDIRS)'; for subdir in $$list; do \
mostlyclean-recursive clean-recursive distclean-recursive \
maintainer-clean-recursive:
- @set fnord $(MAKEFLAGS); amf=$$2; \
+ @set fnord $$MAKEFLAGS; amf=$$2; \
dot_seen=no; \
rev=''; list='$(SUBDIRS)'; for subdir in $$list; do \
rev="$$subdir $$rev"; \
- test "$$subdir" = "." && dot_seen=yes; \
+ test "$$subdir" != "." || dot_seen=yes; \
done; \
test "$$dot_seen" = "no" && rev=". $$rev"; \
target=`echo $@ | sed s/-recursive//`; \
@for file in $(DISTFILES); do \
if test -f $$file; then d=.; else d=$(srcdir); fi; \
if test -d $$d/$$file; then \
- cp -pr $$/$$file $(distdir)/$$file; \
+ cp -pr $$d/$$file $(distdir)/$$file; \
else \
test -f $(distdir)/$$file \
|| ln $$d/$$file $(distdir)/$$file 2> /dev/null \
# FIXME: needs more dependencies
desc: desc.scm
rm -f tmp-desc.h tmp-desc.c tmp-opinst.c
- $(GUILE) -s $(srcdir)/cgen-opc.scm \
+ $(GUILE) $(srcdir)/cgen-opc.scm \
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS)" \
.PHONY: html
html: desc.scm html.scm cgen-doc.scm
rm -f tmp-doc.html
- $(GUILE) -s $(srcdir)/cgen-doc.scm \
+ $(GUILE) $(srcdir)/cgen-doc.scm \
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS)" \
opcodes: opcodes.scm
rm -f tmp-opc.h tmp-itab.c
rm -f tmp-asm.in tmp-dis.in tmp-ibld.h tmp-ibld.in
- $(GUILE) -s $(srcdir)/cgen-opc.scm \
+ $(GUILE) $(srcdir)/cgen-opc.scm \
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS) opinst" \
# FIXME: needs more dependencies
sim-arch: sim.scm
rm -f tmp-arch.h tmp-arch.c tmp-cpuall.h
- $(GUILE) -s $(srcdir)/cgen-sim.scm \
+ $(GUILE) $(srcdir)/cgen-sim.scm \
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS)" \
sim-cpu: sim.scm
rm -f tmp-cpu.h tmp-cpu.c tmp-decode.h tmp-decode.c
rm -f tmp-model.c tmp-sem.c tmp-sem-switch.c
- $(GUILE) -s $(srcdir)/cgen-sim.scm \
+ $(GUILE) $(srcdir)/cgen-sim.scm \
-s $(srcdir) \
$(CGENFLAGS) \
-f "$(OPTIONS)" \
echo "ISAS not specified!" ;\
exit 1 ;\
fi
- $(GUILE) -s $(srcdir)/cgen-gas.scm \
+ $(GUILE) $(srcdir)/cgen-gas.scm \
-s $(srcdir) \
$(CGENFLAGS) \
-a $(ARCHFILE) \
echo "ISAS not specified!" ;\
exit 1 ;\
fi
- $(GUILE) -s $(srcdir)/cgen-stest.scm \
+ $(GUILE) $(srcdir)/cgen-stest.scm \
-s $(srcdir) \
$(CGENFLAGS) \
-a $(ARCHFILE) \
---------------------
dev.scm - top level script for doing interactive development
-fixup.scm - munges the Scheme environment to make it suit us
- [Guile is/was still in flux]
+guile.scm - Guile-specific definitions, and adaptations to specific
+ versions of Guile
cos.scm - OOP implementation
pmacros.scm - preprocessor-style macro package
profile.scm - Guile profiling tool [eventually wish to move this to
; Load the various support routines.
(define (load-files srcdir)
- ; Fix up Scheme to be what we use (guile is always in flux).
- (primitive-load-path (string-append srcdir "/fixup.scm"))
-
(load (string-append srcdir "/read.scm"))
(load (string-append srcdir "/desc.scm"))
(load (string-append srcdir "/desc-cpu.scm"))
; Load the various support routines.
(define (load-files srcdir)
- ; Fix up Scheme to be what we use (guile is always in flux).
- (primitive-load-path (string-append srcdir "/fixup.scm"))
-
(load (string-append srcdir "/read.scm"))
(load (string-append srcdir "/desc.scm"))
(load (string-append srcdir "/desc-cpu.scm"))
\f
; Load the various support routines
(define (load-files srcdir)
- ; Fix up Scheme to be what we use (guile is always in flux).
- (primitive-load-path (string-append srcdir "/fixup.scm"))
-
(load (string-append srcdir "/read.scm"))
(load (string-append srcdir "/desc.scm"))
(load (string-append srcdir "/desc-cpu.scm"))
; (load-sid)
; (cload #:arch arch #:machs "mach-list" #:isas "isa-list" #:options "options")
\f
-; First load fixup.scm to coerce guile into something we've been using.
+; First load guile.scm to coerce guile into something we've been using.
; Guile is always in flux.
-(load "fixup.scm")
+(load "guile.scm")
(define srcdir ".")
(set! %load-path (cons srcdir %load-path))
+++ /dev/null
-; Fix up the current interpreter-du-jour to conform to what we've
-; been working with.
-; Copyright (C) 2000 Red Hat, Inc.
-; This file is part of CGEN.
-; See file COPYING.CGEN for details.
-
-(define *guile-major-version* (string->number (major-version)))
-(define *guile-minor-version* (string->number (minor-version)))
-
-; eval takes a module argument in 1.6 and later
-
-(if (or (> *guile-major-version* 1)
- (>= *guile-minor-version* 6))
- (define (eval1 expr)
- (eval expr (current-module)))
- (define (eval1 expr)
- (eval expr))
-)
-
-; symbol-bound? is deprecated in 1.6
-
-(if (or (> *guile-major-version* 1)
- (>= *guile-minor-version* 6))
- (define (symbol-bound? table s)
- (if table
- (error "must pass #f for symbol-bound? first arg"))
- ; FIXME: Not sure this is 100% correct.
- (module-defined? (current-module) s))
-)
-
-(if (symbol-bound? #f 'load-from-path)
- (begin
- (define (load file)
- (begin
- ;(load-from-path file)
- (primitive-load-path file)
- ))
- )
-)
-
-; FIXME: to be deleted
-(define =? =)
-(define >=? >=)
-
-(if (not (symbol-bound? #f '%stat))
- (begin
- (define %stat stat)
- )
-)
-
-(if (symbol-bound? #f 'debug-enable)
- (debug-enable 'backtrace)
-)
-
-; Guile 1.3 has reverse!, Guile 1.2 has list-reverse!.
-; CGEN uses reverse!
-(if (and (not (symbol-bound? #f 'reverse!))
- (symbol-bound? #f 'list-reverse!))
- (define reverse! list-reverse!)
-)
(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)))
+
+
+\f
+;;; 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))
; 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?))
(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)
(keep-isa "all") ; default is all isas
(flags "")
(moreopts? #t)
+ (debugging #f) ; default is off, for speed
(cep (current-error-port))
(str=? string=?)
)
(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)))
+ (set! debugging #t)
)
((str=? "-d" (car opt))
(let ((prompt (string-append "cgen-" app-name "> ")))
; 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))
+ (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.
-; 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))))
+ (cgen-debugging-stack-start -cgen args))
)
OSDN Git Service
