From abec1ed1afc118a7ef77ef5661b40dc2ab9ec7a0 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sun, 30 Apr 2017 17:43:12 +0200 Subject: [PATCH 2/3] Move "time" macro helper procedures to chicken.internal These helpers are not supposed to be used directly by the user, so let's just move it to the internal module to signal that more clearly. This reduces the immense sprawl of library.scm a little as well. --- batch-driver.scm | 4 ++-- c-platform.scm | 3 ++- chicken-syntax.scm | 5 +++-- internal.scm | 64 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- library.scm | 60 -------------------------------------------------- 5 files changed, 69 insertions(+), 67 deletions(-) diff --git a/batch-driver.scm b/batch-driver.scm index be86ab1..7cb8b51 100644 --- a/batch-driver.scm +++ b/batch-driver.scm @@ -323,7 +323,7 @@ (set! enable-module-registration (not (memq 'no-module-registration options))) (when enable-specialization (set! do-scrutinize #t)) - (when (memq 't debugging-chicken) (##sys#start-timer)) + (when (memq 't debugging-chicken) (start-timer)) (when (memq 'b debugging-chicken) (set! time-breakdown #t)) (when (memq 'raw options) (set! explicit-use-flag #t) @@ -831,7 +831,7 @@ (close-output-port out))) (end-time "code generation") (when (memq 't debugging-chicken) - (##sys#display-times (##sys#stop-timer))) + (display-timer-statistics (stop-timer))) (compiler-cleanup-hook) (dribble "compilation finished.") ) ) ) ) ) ) ) ) ) ) ) ) ) diff --git a/c-platform.scm b/c-platform.scm index 49bbfc0..da68409 100644 --- a/c-platform.scm +++ b/c-platform.scm @@ -59,9 +59,10 @@ ##sys#standard-input ##sys#standard-output ##sys#standard-error ##sys#undefined-value) (bound-to-procedure + chicken.internal#start-timer chicken.internal#stop-timer ##sys#for-each ##sys#map ##sys#print ##sys#setter ##sys#setslot ##sys#dynamic-wind ##sys#call-with-values - ##sys#start-timer ##sys#stop-timer ##sys#gcd ##sys#lcm ##sys#make-promise ##sys#structure? ##sys#slot + ##sys#gcd ##sys#lcm ##sys#make-promise ##sys#structure? ##sys#slot ##sys#allocate-vector ##sys#list->vector ##sys#block-ref ##sys#block-set! ##sys#list ##sys#cons ##sys#append ##sys#vector ##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument ##sys#error ##sys#peek-c-string ##sys#peek-nonnull-c-string diff --git a/chicken-syntax.scm b/chicken-syntax.scm index 65367b8..a1f01ab 100644 --- a/chicken-syntax.scm +++ b/chicken-syntax.scm @@ -150,12 +150,13 @@ (lambda (form r c) (let ((rvar (r 't))) `(##core#begin - (##sys#start-timer) + (chicken.internal#start-timer) (##sys#call-with-values (##core#lambda () ,@(cdr form)) (##core#lambda ,rvar - (##sys#display-times (##sys#stop-timer)) + (chicken.internal#display-timer-statistics + (chicken.internal#stop-timer)) (##sys#apply ##sys#values ,rvar) ) ) ) ) ) ) ) (##sys#extend-macro-environment diff --git a/internal.scm b/internal.scm index b8a7fbb..6ef7628 100644 --- a/internal.scm +++ b/internal.scm @@ -26,8 +26,7 @@ (declare (unit internal) - (disable-interrupts) - (fixnum)) + (disable-interrupts) ) ;; This is a bit of a grab-bag of stuff that's used in various places ;; in the runtime and the compiler, but which is not supposed to be @@ -35,6 +34,9 @@ ;; particular. (module chicken.internal ( + ;; Timing information (support for "time" macro) + start-timer stop-timer display-timer-statistics + ;; Convert string into valid C-identifier string->c-identifier @@ -53,6 +55,64 @@ (include "common-declarations.scm") (include "mini-srfi-1.scm") +;;; Timing information (support for "time" macro): + +(define (start-timer) + (##sys#gc #t) + (##core#inline "C_start_timer")) + +(define (stop-timer) + (let ((info ((##core#primitive "C_stop_timer")))) + ;; Run a major GC one more time to get memory usage information in + ;; case there was no major GC while the timer was running + (##sys#gc #t) + (##sys#setslot info 6 (##sys#slot ((##core#primitive "C_stop_timer")) 6)) + info)) + +(define (display-timer-statistics info) + (define (pstr str) (##sys#print str #f ##sys#standard-error)) + (define (pchr chr) (##sys#write-char-0 chr ##sys#standard-error)) + (define (pnum num) + (##sys#print (if (zero? num) "0" (##sys#number->string num)) #f ##sys#standard-error)) + (define (round-to x y) ; Convert to fp with y digits after the point + (/ (round (* x (expt 10 y))) (expt 10.0 y))) + (define (pmem bytes) + (cond ((> bytes (expt 1024 3)) + (pnum (round-to (/ bytes (expt 1024 3)) 2)) (pstr " GiB")) + ((> bytes (expt 1024 2)) + (pnum (round-to (/ bytes (expt 1024 2)) 2)) (pstr " MiB")) + ((> bytes 1024) + (pnum (round-to (/ bytes 1024) 2)) (pstr " KiB")) + (else (pnum bytes) (pstr " bytes")))) + (##sys#flush-output ##sys#standard-output) + (pnum (##sys#slot info 0)) + (pstr "s CPU time") + (let ((gctime (##sys#slot info 1))) + (when (> gctime 0) + (pstr ", ") + (pnum gctime) + (pstr "s GC time (major)"))) + (let ((mut (##sys#slot info 2)) + (umut (##sys#slot info 3))) + (when (fx> mut 0) + (pstr ", ") + (pnum mut) + (pchr #\/) + (pnum umut) + (pstr " mutations (total/tracked)"))) + (let ((minor (##sys#slot info 4)) + (major (##sys#slot info 5))) + (when (or (fx> minor 0) (fx> major 0)) + (pstr ", ") + (pnum major) + (pchr #\/) + (pnum minor) + (pstr " GCs (major/minor)"))) + (let ((maximum-heap-usage (##sys#slot info 6))) + (pstr ", maximum live heap: ") + (pmem maximum-heap-usage)) + (##sys#write-char-0 #\newline ##sys#standard-error) + (##sys#flush-output ##sys#standard-error)) ;;; Convert string into valid C-identifier: diff --git a/library.scm b/library.scm index 071d85d..0b324db 100644 --- a/library.scm +++ b/library.scm @@ -288,18 +288,6 @@ EOF (define get-environment-variable (foreign-lambda c-string "C_getenv" c-string)) (define executable-pathname (foreign-lambda c-string* "C_executable_pathname")) -(define (##sys#start-timer) - (##sys#gc #t) - (##core#inline "C_start_timer")) - -(define (##sys#stop-timer) - (let ((info ((##core#primitive "C_stop_timer")))) - ;; Run a major GC one more time to get memory usage information in - ;; case there was no major GC while the timer was running - (##sys#gc #t) - (##sys#setslot info 6 (##sys#slot ((##core#primitive "C_stop_timer")) 6)) - info)) - (define (##sys#immediate? x) (not (##core#inline "C_blockp" x))) (define (##sys#message str) (##core#inline "C_message" str)) (define (##sys#byte x i) (##core#inline "C_subbyte" x i)) @@ -5639,54 +5627,6 @@ EOF (loop nxt) ) ) ) ) ) -;;; Print timing information (support for "time" macro): - -(define (##sys#display-times info) - (define (pstr str) (##sys#print str #f ##sys#standard-error)) - (define (pchr chr) (##sys#write-char-0 chr ##sys#standard-error)) - (define (pnum num) - (##sys#print (if (zero? num) "0" (##sys#number->string num)) #f ##sys#standard-error)) - (define (round-to x y) ; Convert to fp with y digits after the point - (/ (round (* x (expt 10 y))) (expt 10.0 y))) - (define (pmem bytes) - (cond ((> bytes (expt 1024 3)) - (pnum (round-to (/ bytes (expt 1024 3)) 2)) (pstr " GiB")) - ((> bytes (expt 1024 2)) - (pnum (round-to (/ bytes (expt 1024 2)) 2)) (pstr " MiB")) - ((> bytes 1024) - (pnum (round-to (/ bytes 1024) 2)) (pstr " KiB")) - (else (pnum bytes) (pstr " bytes")))) - (##sys#flush-output ##sys#standard-output) - (pnum (##sys#slot info 0)) - (pstr "s CPU time") - (let ((gctime (##sys#slot info 1))) - (when (> gctime 0) - (pstr ", ") - (pnum gctime) - (pstr "s GC time (major)"))) - (let ((mut (##sys#slot info 2)) - (umut (##sys#slot info 3))) - (when (fx> mut 0) - (pstr ", ") - (pnum mut) - (pchr #\/) - (pnum umut) - (pstr " mutations (total/tracked)"))) - (let ((minor (##sys#slot info 4)) - (major (##sys#slot info 5))) - (when (or (fx> minor 0) (fx> major 0)) - (pstr ", ") - (pnum major) - (pchr #\/) - (pnum minor) - (pstr " GCs (major/minor)"))) - (let ((maximum-heap-usage (##sys#slot info 6))) - (pstr ", maximum live heap: ") - (pmem maximum-heap-usage)) - (##sys#write-char-0 #\newline ##sys#standard-error) - (##sys#flush-output ##sys#standard-error)) - - ;;; Dump heap state to stderr: (define ##sys#dump-heap-state (##core#primitive "C_dump_heap_state")) -- 2.1.4