From 85f8a695860c5ae21c08b79280945a1f8a2525d8 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 30 Mar 1988 21:56:15 +0000 Subject: [PATCH] Change time reports to match compiler. --- v7/src/sf/make.scm | 7 +++++-- v7/src/sf/toplev.scm | 48 +++++++++++++++++++++++++------------------- v8/src/sf/toplev.scm | 48 +++++++++++++++++++++++++------------------- 3 files changed, 59 insertions(+), 44 deletions(-) diff --git a/v7/src/sf/make.scm b/v7/src/sf/make.scm index 1e7cff184..e1eadd89e 100644 --- a/v7/src/sf/make.scm +++ b/v7/src/sf/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.1 1988/03/25 20:50:11 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.2 1988/03/30 21:56:15 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -61,9 +61,12 @@ MIT in each case. |# (make-environment (define :name "SF") (define :version 4) - (define :modification 0) + (define :modification 2) (define :files) + (define :rcs-header ;RCS sets up this string. + "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 4.2 1988/03/30 21:56:15 cph Rel $") + (define :files-lists (list (cons system-global-environment diff --git a/v7/src/sf/toplev.scm b/v7/src/sf/toplev.scm index 58c8ae889..b5d144800 100644 --- a/v7/src/sf/toplev.scm +++ b/v7/src/sf/toplev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 3.6 1988/03/22 17:40:18 jrm Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 3.7 1988/03/30 21:54:08 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -275,10 +275,10 @@ Currently only the 68000 implementation needs this." expression)))) (define (integrate/kernel get-scode declarations) - (fluid-let ((previous-real-time false) - (previous-process-time false) - (previous-name false) - (events '())) + (fluid-let ((previous-name false) + (previous-process-time false) + (previous-real-time false) + (events '())) (transmit-values (transmit-values (transmit-values @@ -322,31 +322,37 @@ Currently only the 68000 implementation needs this." (return-2 (operations->external operations environment) (cgen/expression expression))) -(define previous-real-time) -(define previous-process-time) (define previous-name) +(define previous-process-time) +(define previous-real-time) (define events) (define (mark-phase this-name) (end-phase) (newline) - (write-string " ") + (write-string " ") (write-string this-name) (write-string "...") (set! previous-name this-name)) (define (end-phase) - (let ((this-time (real-time-clock)) - (this-process-time (runtime))) - (if previous-real-time - (let ((dt (- this-time previous-real-time)) - (dpt (- this-process-time previous-process-time))) - (set! events (cons (cons previous-name dt) events)) - (newline) - (write-string " Time: ") - (write (floor (/ dt 1000.))) - (write-string " seconds (real); ") - (write dpt) - (write-string " seconds (process)."))) + (let ((this-process-time (runtime)) + (this-real-time (real-time-clock))) + (if previous-process-time + (let ((delta-process-time (- this-process-time previous-process-time))) + (set! events (cons (cons previous-name delta-process-time) events)) + (time-report " Time taken" + delta-process-time + (- this-real-time previous-real-time)))) (set! previous-real-time this-time) - (set! previous-process-time this-process-time))) \ No newline at end of file + (set! previous-process-time this-process-time))) + +;; Should match the compiler. We'll merge the two at some point. +(define (time-report prefix process-time real-time) + (newline) + (write-string prefix) + (write-string ": ") + (write (/ process-time 1000)) + (write-string " (process time); ") + (write (/ real-time 1000)) + (write-string " (real time)")) \ No newline at end of file diff --git a/v8/src/sf/toplev.scm b/v8/src/sf/toplev.scm index 1f1553c91..27a295e73 100644 --- a/v8/src/sf/toplev.scm +++ b/v8/src/sf/toplev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 3.6 1988/03/22 17:40:18 jrm Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 3.7 1988/03/30 21:54:08 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -275,10 +275,10 @@ Currently only the 68000 implementation needs this." expression)))) (define (integrate/kernel get-scode declarations) - (fluid-let ((previous-real-time false) - (previous-process-time false) - (previous-name false) - (events '())) + (fluid-let ((previous-name false) + (previous-process-time false) + (previous-real-time false) + (events '())) (transmit-values (transmit-values (transmit-values @@ -322,31 +322,37 @@ Currently only the 68000 implementation needs this." (return-2 (operations->external operations environment) (cgen/expression expression))) -(define previous-real-time) -(define previous-process-time) (define previous-name) +(define previous-process-time) +(define previous-real-time) (define events) (define (mark-phase this-name) (end-phase) (newline) - (write-string " ") + (write-string " ") (write-string this-name) (write-string "...") (set! previous-name this-name)) (define (end-phase) - (let ((this-time (real-time-clock)) - (this-process-time (runtime))) - (if previous-real-time - (let ((dt (- this-time previous-real-time)) - (dpt (- this-process-time previous-process-time))) - (set! events (cons (cons previous-name dt) events)) - (newline) - (write-string " Time: ") - (write (floor (/ dt 1000.))) - (write-string " seconds (real); ") - (write dpt) - (write-string " seconds (process)."))) + (let ((this-process-time (runtime)) + (this-real-time (real-time-clock))) + (if previous-process-time + (let ((delta-process-time (- this-process-time previous-process-time))) + (set! events (cons (cons previous-name delta-process-time) events)) + (time-report " Time taken" + delta-process-time + (- this-real-time previous-real-time)))) (set! previous-real-time this-time) - (set! previous-process-time this-process-time))) \ No newline at end of file + (set! previous-process-time this-process-time))) + +;; Should match the compiler. We'll merge the two at some point. +(define (time-report prefix process-time real-time) + (newline) + (write-string prefix) + (write-string ": ") + (write (/ process-time 1000)) + (write-string " (process time); ") + (write (/ real-time 1000)) + (write-string " (real time)")) \ No newline at end of file -- 2.25.1