home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / DEBUG.SCM < prev    next >
Text File  |  1992-06-17  |  7KB  |  263 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Commands for debugging.
  5.  
  6. (export! system-package '(show-undefined-variables))  ;grumble
  7.  
  8.  
  9. ; Benchmark mode (i.e., inline primitives)
  10.  
  11. (define (bench-command)
  12.   (let ((b (not *benchmark-mode?*)))
  13.     (set-benchmark-mode! b)
  14.     (set! *benchmark-mode?* b)
  15.     (write-line (if b "Benchmark mode enabled" "Benchmark mode disabled")
  16.         (fluid $output-port))))
  17.  
  18. (define *benchmark-mode?* #t)
  19.  
  20. (define-command 'bench "" "benchmark mode (integrate primitives)"
  21.   '() bench-command)
  22.  
  23.  
  24. ; :flush
  25.  
  26. (define-command 'flush "" "flush initial debug information database"
  27.   '() flush-debug-info)
  28.  
  29.  
  30. ; :collect
  31.  
  32. (define (collect-command)
  33.   (let ((port (fluid $output-port))
  34.     (before (vm 0 #f)))
  35.     (collect)
  36.     (let ((after (vm 0 #f)))
  37.       (display "Before: " port)
  38.       (write before port)
  39.       (newline)
  40.       (display "After:  " port)
  41.       (write after port)
  42.       (newline))))
  43.  
  44. (define-command 'collect "" "GC" '() collect-command)
  45.  
  46. ; :undefined
  47.  
  48. (define (show-undefined-variables)
  49.   (let ((out (fluid $output-port))
  50.     (undef (undefined-variables (fluid $package-for-commands))))
  51.     (if (not (null? undef))
  52.     (begin (display "Undefined: " out)
  53.            (write undef out)
  54.            (newline out)))))
  55.  
  56. (define-command 'undefined "" "list undefined variables"
  57.   '() show-undefined-variables)
  58.  
  59. ; :preview  -- show continuations
  60.  
  61. (define (preview)
  62.   (continuation-preview (command-loop-continuation)))
  63.  
  64. (define (continuation-preview c)
  65.   (if (continuation? c)
  66.       (begin 
  67.     (let ((name (template-name (continuation-template c))))
  68.       (cond ((and name
  69.               ;; Pretty kludgey, huh?
  70.               (not (member name preview-ignored-names)))
  71.          (display "  ")
  72.          (write name)
  73.          (newline))))
  74.     (continuation-preview (next-ripe-continuation c)))))
  75.  
  76. (define preview-ignored-names '(with-dynamic-env))
  77.  
  78. ;    If (continuation-cont A) = B, then ignore B if
  79. ;        1. (continuation-template B) = (continuation-template A)
  80. ;        2. (continuation-pc B) > (continuation-pc A)
  81. ;        3. (continuation-env B) = (continuation-env A)
  82. ;                                  or some parent of (continuation-env A)
  83.  
  84. (define (next-ripe-continuation a)
  85.   (let ((b (continuation-cont a)))
  86.     (if (and (continuation? b)
  87.          (eq? (continuation-template b) (continuation-template a))
  88.          (> (continuation-pc b) (continuation-pc a))
  89.          (let loop ((env (continuation-env A)))
  90.            (or (eq? env (continuation-env B))
  91.            (and (vector? env)
  92.             (loop (vector-ref env 0))))))
  93.     (next-ripe-continuation b)
  94.     b)))
  95.  
  96.  
  97. (define-command 'preview "" "show continuations (stack trace)"
  98.   '() preview)
  99.  
  100. ; Proceed
  101.  
  102. (define (proceed . value-option)
  103.   (let ((value (if (null? value-option)
  104.            (unspecified)
  105.            (car value-option)))
  106.     (level (car (fluid $command-levels))))
  107.     (if (ok-to-proceed? level)
  108.     (throw-to-command-level level (lambda () value))
  109.     (write-line "No way to proceed from here." (fluid $output-port)))))
  110.  
  111. (define-command 'proceed "<exp>" "proceed after interrupt or error"
  112.   '(&rest value) proceed)
  113.  
  114. ; Scrutinize the condition to ensure that it's safe to return from the
  115. ; call to RAISE.
  116.  
  117. (define (ok-to-proceed? level)
  118.   (let ((condition (command-level-condition level)))
  119.     (cond ((not condition) #f)
  120.       ((or (warning? condition)
  121.            (interrupt? condition)
  122.            (breakpoint? condition))
  123.        #t)
  124.       ((exception? condition)
  125.        (let ((opcode (exception-opcode condition)))
  126.          (or (= opcode op/global)
  127.          (= opcode op/local0)
  128.          (= opcode op/set-global!))))
  129.       (else #f))))
  130.  
  131. (define (breakpoint . rest)
  132.   (command-loop unspecified (cons 'breakpoint rest)))
  133.  
  134. (define (breakpoint? condition)
  135.   (and (pair? condition) (eq? (car condition) 'breakpoint)))
  136.  
  137.  
  138. (define (go-to-level n)
  139.   (let ((levels (reverse (fluid $command-levels))))
  140.     (if (and (integer? n)
  141.          (>= n 0)
  142.          (< n (length levels)))
  143.     (throw-to-command-level (list-ref levels n)
  144.                 (lambda ()
  145.                   (command-loop unspecified #f)))
  146.     (write-line "invalid command level" (fluid $output-port)))))
  147.  
  148. (define-command 'level "<number>" "go to command level"
  149.   '(expression) go-to-level)
  150.  
  151.  
  152.  
  153. ; Trace and untrace
  154.  
  155. (define (trace . names)
  156.   (if (null? names)
  157.       (let ((port (fluid $output-port)))
  158.     (write (map car (fluid $traced)) port)
  159.     (newline port))
  160.       (for-each trace-1 names)))
  161.  
  162. (define-command 'trace "<name> ..." "trace calls to given procedure(s)"
  163.   '(&rest name) trace)
  164.  
  165. (define (untrace . names)
  166.   (if (null? names)
  167.       (for-each untrace-1 (map car (fluid $traced)))
  168.       (for-each untrace-1 names)))
  169.  
  170. (define-command 'untrace "<name> ..." "stop tracing calls"
  171.   '(&rest name) untrace)
  172.  
  173. ; Trace internals
  174.  
  175. (define $traced       (make-fluid '()))
  176.  
  177. (define (trace-1 name)
  178.   (let* ((env (fluid $package-for-commands))
  179.      (proc (environment-ref env name))
  180.      (traced (make-traced proc name)))
  181.     (set-fluid! $traced
  182.         (cons (list name traced proc env)
  183.               (fluid $traced)))
  184.     (environment-define! env name traced))) ;was environment-set!
  185.        
  186. ; Should be doing clookup's here -- avoid creating new locations
  187.  
  188. (define (untrace-1 name)
  189.   (let ((probe (assq name (fluid $traced))))
  190.     (if probe
  191.     (let* ((traced (cadr probe))
  192.            (proc (caddr probe))
  193.            (env (cadddr probe)))
  194.       (if (eq? (environment-ref env name) traced)
  195.           (environment-set! env name proc)
  196.           (write-line "Value changed since :trace; not restoring it."
  197.               (fluid $output-port)))
  198.       (set-fluid! $traced
  199.               (filter (lambda (x)
  200.                 (not (eq? (car x) name)))
  201.                   (fluid $traced))))
  202.     (write-line "?" (fluid $output-port)))))
  203.  
  204. (define (make-traced proc name)
  205.   (lambda args
  206.     (apply-traced proc name args)))
  207.  
  208. (define (apply-traced proc name args)
  209.   (let ((port (fluid $output-port)))
  210.     (display "[Enter " port)
  211.     (write (cons name (map value->expression args)) port)
  212.     (newline port)
  213.     (let ((result (apply proc args)))
  214.       (display " Leave " port)
  215.       (write name port)
  216.       (display " " port)
  217.       (write (value->expression result) port)
  218.       (display "]" port)
  219.       (newline port)
  220.       result)))
  221.  
  222. ; Timer stuff.
  223. ; Assumes that (vm 1 #f) returns process run time in internal timer units
  224. ; and (vm-extension 1 #f) returns number of timer units per second.
  225.  
  226. (define (time-command form)
  227.   (let* ((thunk (eval `(lambda () ,form) (fluid $package-for-commands)))
  228.      (start-time (vm 1 #f))
  229.      (result (thunk))
  230.      (stop-time (vm 1 #f))
  231.      (dt (- stop-time start-time))
  232.      (units-per-second (vm-extension 1 #f))
  233.      (delta (quotient (* dt 100) units-per-second))
  234.      (port (fluid $output-port)))
  235.     (display "Run time: " port)
  236.     (write-hundredths delta port)
  237.     (display " seconds" port)
  238.     (newline port)
  239.     (print-command-result result)))
  240.  
  241. (define (write-hundredths n port)
  242.   (write (quotient n 100) port)
  243.   (write-char #\. port)
  244.   (let ((r (remainder n 100)))
  245.     (if (< r 10)
  246.     (write-char #\0 port))
  247.     (write r port)))
  248.  
  249. (define-command 'time "<exp>" "measure execution time"
  250.   '(expression) time-command)
  251.  
  252.  
  253.  
  254. ; User-friendly version (doesn't really belong here)
  255.  
  256. (define (with-handler h thunk)
  257.   (really-with-handler (lambda (condition handlers)
  258.              (let-condition-handlers handlers
  259.                (lambda ()
  260.                  (h condition)))
  261.              (try-handlers condition handlers))
  262.                thunk))
  263.