ADDED   utils/trace/trace.import.scm
Index: utils/trace/trace.import.scm
==================================================================
--- /dev/null
+++ utils/trace/trace.import.scm
@@ -0,0 +1,32 @@
+;;;; trace.import.scm - GENERATED BY CHICKEN 4.9.0.1 -*- Scheme -*-
+
+(eval '(import
+         scheme
+         chicken
+         csi
+         advice
+         extras
+         ports
+         data-structures
+         (except srfi-1 break)
+         miscmacros))
+(##sys#register-compiled-module
+  'trace
+  (list)
+  '((breakpoint . trace#breakpoint)
+    (trace . trace#trace)
+    (untrace . trace#untrace)
+    (break . trace#break)
+    (unbreak . trace#unbreak)
+    (trace-output-port . trace#trace-output-port)
+    (continue . trace#continue)
+    (c . trace#c)
+    (traced? . trace#traced?)
+    (trace-module . trace#trace-module)
+    (untrace-module . trace#untrace-module)
+    (trace-verbose . trace#trace-verbose)
+    (trace/untrace . trace#trace/untrace))
+  (list)
+  (list))
+
+;; END OF FILE

ADDED   utils/trace/trace.meta
Index: utils/trace/trace.meta
==================================================================
--- /dev/null
+++ utils/trace/trace.meta
@@ -0,0 +1,10 @@
+;;;; trace.meta -*- Scheme -*-
+
+
+((category tools)
+ (synopsis "tracing and breakpoints")
+ (author "felix winkelmann")
+ (license "public domain")
+ (needs advice				; don't we all?
+	miscmacros)
+ (files "tests/run.scm" "trace.meta" "trace.release-info" "trace.scm" "trace.setup") )

ADDED   utils/trace/trace.scm
Index: utils/trace/trace.scm
==================================================================
--- /dev/null
+++ utils/trace/trace.scm
@@ -0,0 +1,259 @@
+;;;; trace.scm
+
+
+(module trace (breakpoint 
+	       trace untrace
+	       break unbreak
+	       trace-output-port
+	       continue c 
+	       traced?
+	       trace-module untrace-module
+	       trace-verbose
+	       trace/untrace)
+	       
+(import scheme chicken csi)
+
+(use advice extras ports data-structures)
+(require-library srfi-1)
+(import (except srfi-1 break) miscmacros)
+
+
+(define *last-breakpoint* #f)
+(define *traced-procedures* '())
+(define *broken-procedures* '())
+(define *trace-indent-level* 0)
+
+(define trace-output-port (make-parameter (current-output-port)))
+(define trace-verbose (make-parameter #t))
+
+(define (break-entry name args)
+  ;; Does _not_ unwind!
+  (##sys#call-with-current-continuation
+   (lambda (c)
+     (let ((exn (##sys#make-structure
+		 'condition
+		 '(exn breakpoint)
+		 (list '(exn . message) "*** breakpoint ***"
+		       '(exn . arguments) (list (cons name args))
+		       '(exn . location) name
+		       '(exn . continuation) c) ) ) )
+       (set! *last-breakpoint* exn)
+       (signal exn) ) ) ) )
+
+(define (break-resume exn)
+  (let ((a (member '(exn . continuation) (##sys#slot exn 2))))
+    (if a
+	((cadr a) (void))
+	(error "condition has no continuation" exn) ) ) )
+
+(define (breakpoint #!optional (name 'breakpoint))
+  (break-entry name '()) )
+
+(define (trace-indent)
+  (let ((port (trace-output-port)))
+    (do ((i (fxmin 3 *trace-indent-level*) (fx- i 1)))
+	((fx<= i 0))
+      (write-char #\space port) )
+    (fprintf port "[~a] " *trace-indent-level*) ) )
+
+(define (traced-procedure-entry name args)
+  (let ((port (trace-output-port)))
+    (trace-indent)
+    (set! *trace-indent-level* (fx+ 1 *trace-indent-level*))
+    (write (cons name args) port)
+    (write ", Called from: " port)
+    (write (conc (car (reverse (get-call-chain)))))
+    (write-char #\newline port)
+    (flush-output port) ) )
+
+(define (traced-procedure-exit name results)
+  (let ((port (trace-output-port)))
+    (set! *trace-indent-level* (fx- *trace-indent-level* 1))
+    (trace-indent)
+    (fprintf port "~a -> " name)
+    (if results
+	(for-each
+	 (lambda (x)
+	   (write x port)
+	   (write-char #\space port) )
+	 results)
+	(display "(escaping)" port))
+    (write-char #\newline port)
+    (flush-output port) ) )
+
+(define (procedure-name proc)
+  (cond ((procedure-information proc) =>
+	 (lambda (info)
+	   (if (pair? info) (car info) info) ) )
+	(else '<unknown>)) )
+
+(define (do-trace procs)
+  (for-each
+   (lambda (s)
+     (ensure procedure? s)
+     (cond ((traced? s)
+	    (warning "procedure already traced" s) )
+	   (else
+	    (let ((name (procedure-name s)))
+	      (when (trace-verbose)
+		(fprintf (current-error-port) "; tracing ~a~%" name))
+	      (set! *traced-procedures* (cons (cons s name) *traced-procedures*))
+	      (advise 
+	       'around s
+	       (lambda (next args)
+		 (let ((results #f))
+		   (dynamic-wind
+		       (cut traced-procedure-entry name args)
+		       (lambda () 
+			 (call-with-values (cut apply next args)
+			   (lambda rs
+			     (set! results rs)
+			     (apply values rs))))
+		       (cut traced-procedure-exit name results))))
+	       '*trace*)))))
+   procs) )
+
+(define (do-untrace-all)
+  (define (unadvise* p)
+    (ignore-errors (unadvise p '*trace*)))
+  (for-each
+   (lambda (proc)
+     (let ((proc (car proc)))
+       (when (trace-verbose)
+	 (fprintf (current-error-port) "; untracing ~a~%" (procedure-name proc))
+	 (unadvise* proc))))
+   *traced-procedures*)
+  (set! *traced-procedures* '()))
+
+(define (do-untrace procs)
+  (for-each
+   (lambda (s)
+     (ensure procedure? s)
+     (let ((p (assq s *traced-procedures*)) 
+	   (name (procedure-name s)))
+       (cond ((not p) (warning "procedure not traced" name))
+	     (else
+	      (when (trace-verbose)
+		(fprintf (current-error-port) "; untracing ~a~%" name))
+	      (ignore-errors (unadvise s '*trace*))
+	      (set! *traced-procedures* 
+		(delete 
+		 p *traced-procedures* 
+		 eq?))))))
+   procs) )
+
+(define (do-break procs)
+  (for-each
+   (lambda (s)
+     (let ((name (procedure-name s)))
+       (ensure procedure? s)
+       (cond ((assq s *broken-procedures*)
+	      (warning "procedure already has break-point" name))
+	     (else
+	      (when (trace-verbose)
+		(fprintf (current-error-port) "; setting break-point in ~a~%" name))
+	      (set! *broken-procedures* (cons (cons s name) *broken-procedures*))
+	      (advise 
+	       'before s
+	       (lambda (args)
+		 (break-entry name args) )
+	       '*break*) ) )))
+   procs) )
+
+(define (do-unbreak procs)
+  (for-each
+   (lambda (s)
+     (ensure procedure? s)
+     (let ((p (assq s *broken-procedures*)) 
+	   (name (procedure-name s)))
+       (cond ((not p) (warning "procedure has no breakpoint" name))
+	     (else
+	      (when (trace-verbose)
+		(fprintf (current-error-port) "; removing break-point in ~a~%" name))
+	      (ignore-errors (unadvise s '*break*))
+	      (set! *broken-procedures* (delete p *broken-procedures* eq?) ) ) ) ) )
+   procs) )
+
+(define (do-unbreak-all)
+  (for-each
+   (lambda (bp)
+     (ignore-errors (unadvise (car bp) '*break*)))
+   *broken-procedures*)
+  (set! *broken-procedures* '())
+  (void))
+
+(define (trace . procs)
+  (cond ((null? procs)
+	 (when (pair? *traced-procedures*)
+	   (printf "Traced:~%~%")
+	   (for-each (lambda (p) (printf "  ~a~%" (cdr p))) *traced-procedures*)) )
+	(else
+	 (do-trace procs) ) ) )
+
+(define (untrace . procs)
+  (cond ((null? procs) (do-untrace-all))
+	(else (do-untrace procs)))
+  (void))
+
+(define (break . procs)
+  (cond ((null? procs)
+	 (when (pair? *broken-procedures*)
+	   (printf "Breakpoints:~%~%")
+	   (for-each (lambda (p) (printf "  ~a~%" (cdr p))) *broken-procedures*)) )
+	(else
+	 (do-break procs) ) ) )
+
+(define (unbreak . procs)
+  (cond ((null? procs) (do-unbreak-all))
+	(else (do-unbreak procs))))
+
+(define (continue #!optional (bp *last-breakpoint*))
+  (cond (*last-breakpoint*
+	 (let ((exn *last-breakpoint*))
+	   (set! *last-breakpoint* #f)
+	   (break-resume exn) ) )
+	(else (display "no breakpoint pending\n") ) ) )
+
+(define c continue)
+
+(define (traced? proc)
+  (assq proc *traced-procedures*))
+
+(define (trace/untrace . procs)
+  (for-each
+   (lambda (proc)
+     ((if (traced? proc) do-untrace do-trace) (list proc)))
+   procs))
+
+(define (walk-module mname proc)
+  (let* ((m (##sys#find-module mname))
+	 (exps (nth-value 1 (##sys#module-exports m))))
+    (for-each
+     (lambda (exp)
+       (let* ((realname (cdr exp))
+	      (prim (get realname '##core#primitive)))
+	 (if prim
+	     (warning "export is a core-library primitive - not traced" (car exp))
+	     (when (##sys#symbol-has-toplevel-binding? realname)
+	       (let ((val (##sys#slot realname 0)))
+		 (when (procedure? val)
+		   (proc val)))))))
+     exps)))
+
+(define (trace-module . mnames)
+  (for-each
+   (lambda (mname)
+     (walk-module mname trace))
+   mnames))
+
+(define (untrace-module . mnames)
+  (for-each
+   (lambda (mname)
+     (walk-module 
+      mname 
+      (lambda (proc)
+	(when (traced? proc)
+	  (do-untrace (list proc))))))
+   mnames))
+
+)

ADDED   utils/trace/trace.setup
Index: utils/trace/trace.setup
==================================================================
--- /dev/null
+++ utils/trace/trace.setup
@@ -0,0 +1,9 @@
+;;;; trace.setup -*- Scheme -*-
+
+
+(compile -s trace.scm -O3 -d1 -j trace)
+(compile -s trace.import.scm -O3 -d0)
+
+(install-extension
+ 'trace
+ '("trace.so" "trace.import.so"))